---
title: "Can Citizens Guess How Other Citizens Voted Based on Demographic Characteristics?"
author:
- affiliation: London School of Economics and Political Science
  name: Noam Titelman
- affiliation: University College London
  name: Benjamin E Lauderdale
date: "`r format(Sys.time(), '%B %d, %Y')`"
output:
  pdf_document:
    citation_package: natbib
    fig_caption: yes
    keep_tex: yes
    latex_engine: xelatex
    template: header.tex
  html_document:
    df_print: paged
  word_document: default
classoption: a4paper
biblio-style: apsr
geometry: margin=1in
keywords: ""
bibliography: master.bib
spacing: double
thanks: "The authors would like to thank Chris Hanretty, Tom O’Grady, and workshop participants at Durham University, as well as the editor and reviewers at this journal, for their feedback on earlier versions of this paper; **Corresponding author**: n.titelman@lse.ac.uk"
abstract: How well do citizens understand the associations between social groups and political divisions in their societies?  Previous research has indicated systematic biases in how the demographic composition of party supporters are perceived, but this need not imply that citizens misperceive the likely voting behaviour of specific individuals. We report results from two experiments where subjects were provided with randomly selected demographic profiles of respondents to the 2017 British Election Study (BES) and then asked to assess either (1) which party that individual was likely to have voted for in the 2017 UK election or (2) whether that individual was likely to have voted Leave or Remain in the 2016 UK referendum on EU membership.  We find that, despite substantial overconfidence in individual responses, on average citizens' guesses broadly reflect the actual distribution of groups supporting the parties and referendum positions.
---

```{r,include=FALSE}

library(knitr)
knitr::opts_chunk$set(eval = TRUE, echo = FALSE, message=FALSE, warning=FALSE)

library(matlib)
library(DescTools)
library(survey)
library(dplyr)
library(ggplot2)
library(ggthemes)
library(gridExtra)
library(plotrix)
library(plyr)
library(coefplot)
library(questionr)
library(psych)
library(snakecase)
library(stargazer)
library(texreg)
library(tidyr)
library(forcats)
library(stringr)
library(kableExtra)
library(rlang)
library(naniar)



load("CleanBrexit.RData")
load("CleanParties.RData")


```

# Introduction

Public discussions of voter behaviour sometimes suggest that social groupings align much more strongly and simply with voter behaviour than is actually the case. As @ford2019has lament: 

> It's not that there are not under-pinning factors driving the way people vote, merely that voters are much more complicated than most discussion of this sort of analysis ever allows.   Even individual voters are complex and contradictory, so this will certainly be true of any group of voters — whether we define them by place, or profession, or past vote or anything else.

\noindent It is not only pundits who tend to misperceive associations between voter behaviour and demographic characteristics.  Recent studies in political science have found that citizens [@levendusky2016mis;@mildenberger2019beliefs] as well as representatives [@broockman2018bias] can be biased on average when assessing the aggregate political attitudes of the public.  These findings are consistent with an older literature on such biases in social psychology [@pronin200236;@sherman2003naive;@chambers2006misperceptions;@todorov2004public;@shamir1997pluralistic]. In contrast to these findings of bias, other researchers have found that citizens' average ex-ante forecasts of aggregate electoral outcomes are often (but not always) close to accurate [@lewis-beck2011citizen;@rothschild2011forecasting;@murr2011wisdom;@graefe2014accuracy;@murr2016wisdom;@boon2012predicting], illustrating that citizens' can collectively form unbiased assessments of one another's votes in some instances.  Of course there is no reason to expect a single, consistent answer to all questions of the form: "do these [citizens/representatives] have unbiased perceptions of [measure of public opinion or voting behaviour]?"  The direction, magnitude, and consequences of biases may vary substantially across different contexts.

Our focus in this paper is specifically on public perceptions about the relationship between socio-demographic characteristics and vote choice.  Two recent studies in the US find that people tend to "overestimate the extent to which party supporters belong the party-stereotypical groups" [@ahler2018parties] and that "evangelicals tend to overestimate the percent of Republicans who are evangelicals and overestimate the percent of Democrats who are secular (seculars exhibit more muted, but opposite patterns)." [@claassen2019which].  

These studies have asked respondents to make assessments at the population-level, with prompts that ask respondents for $p(X|vote)$: the proportion of people with a given characteristic ($X$) among those voting for a particular party ($vote$).  These "compositional" questions are interesting because they tell us about the "images" of party supporters that respondents bring to mind.  @ahler2018parties provide experimental evidence that misperceptions about the composition of party supporters are consequential because they increase perceived distance of individuals from the parties they do not support.  

Our study complements this work by asking respondents to report their beliefs about $p(vote|X)$ instead of $p(X|vote)$. That is, instead of asking what proportion of the people who voted a given way have a particular demographic attribute, we ask what proportion of the people with given demographic attributes voted in a particular way.  Where the "compositional" question asked by previous studies is useful to assessing "party images", our "behavioural" question tells us about the assumptions that individuals make about the political behaviour of a *specific* person, based on that person's demographic characteristics.  Both compositional and behavioural assessments are important quantities to understand if our goal is to assess the political assumptions that citizens are making about one another.  

Both of these quantities, $p(vote|X)$ and $p(X|vote)$, are likely to be difficult for respondents to report on a survey.  They ask respondents to report quantities that could only be measured accurately using cross-tabulations of nationally representative surveys.  In general, survey respondents struggle with questions that ask for shares of groups in the population [e.g. @joslyn2018motivated; @kunovich2017perceptions].  Mistakes in reporting probabilities can take the form of overly extreme probabilities [e.g. @kahneman2011thinking] or probabilities overly close to 50%, depending on circumstances [@baron2014two;@atanasov2017distilling].  In terms of the specific information required to answer accurately, the compositional question $p(X|vote)$ is more difficult than the behavioural question $p(vote|X)$, as only the latter is typically reported  in the media when presenting demographic breakdowns of election results.  Indeed, @ahler2020typecast propose that citizens' understandings of these proportions might be linked.  They argue that citizens might be more familiar with $p(vote|X)$  and therefore recover $p(X|vote)$ by implicitly calculating (perhaps inaccurately) the relationship between the two: $p(X|vote) = p(vote|X)p(X)/p(vote)$.  There are multiple ways that citizens might err in applying Bayes rule, but the most likely are by failing to implicitly multiply $p(vote|X)$ by $p(X)/p(vote)$ at all, or by holding inaccurate beliefs about the base population proportions of $p(X)$.   Implicit in Ahler and Sood's argument is the idea that citizens might hold accurate beliefs about $p(vote|X)$.  We test if, in fact, citizens can report accurate beliefs about this probability.

We examine citizens' perceptions about $p(vote|X)$, assessing perceptions about many social groupings ($X$) jointly rather than one at a time.  Our two experiments consist of presenting profiles of voter characteristics (such as income, education, social class, ethnicity, religion, place of residence, age, etc). In the first experiment we ask a group of respondents to assess which party that individual was likely to have voted for in the 2017 UK election. In the second experiment we ask another group of respondents whether that individual was likely to have voted Leave or Remain in the 2016 UK referendum on EU membership.  The profiles of characteristics presented were randomly selected from the profiles of respondents to the face-to-face survey of the 2017 British Election Study (BES), so we know the true reported vote choice in both the 2016 referendum and 2017 election for each treatment profile, and the treatment profiles are representative in distribution of the voters in the referendum and election.  This allows us to benchmark public perceptions against the actual demographic associations in a variety of ways.

We find that on *average*, citizens' perceptions broadly reflect the actual demographic associations of voting.  Across a very large number of demographic attributes and the two different vote choices, we find only a single attribute where respondents are, in the aggregate, directionally mistaken (on average respondents think that holding a university degree was associated with voting Conservative in 2017, when in fact it was associated with voting Labour).  Otherwise, for both the "old" political divide of party and the "new" political divide of Brexit, respondents' assessments are responsive to variation in profiles in qualitatively correct ways, and often capture the relative strength of associations well.  At the same time, while *average* beliefs track reality reasonably well, at the individual-level guesses are noisy and overconfident, and so respondents do not perform well in probabilistic assessments like Brier score.  We show that this reflects the difficulties of making probabilistic assessments of what proportion of people with a given profile will have voted in a specific way.  The accuracy of respondents' perceptions increases with their level of political attention, but is not consistently predicted by any other measured characteristic of the respondent.  

Whereas previous work by @ahler2018parties found that respondents caricature party supporters, and do so more when they are more interested in politics, we do not find any such tendency.  While we examine a different setting (the UK rather than the US), we believe it is more likely that these different findings are the result of the different way in which we elicit respondents' understandings of how political divides intersect with social and demographic groups in the population.  Compositional questions make it easier to overstate demographic associations with vote, because demographic characteristics are presented one-at-a-time. In contrast, the behavioural question that we ask requires respondents to evaluate each demographic attribute in the context of many at once, to think about a particular person with a full profile of attributes.  In this context, overstating one demographic association requires ignoring others.  We find that respondents do not do this, at least not on average with respect to any particular attribute.  This is true even though respondents give far too many extreme responses, frequently (and implausibly) stating that certain profiles are 100% or 0% likely to have voted Leave, Remain, Conservative or Labour.

Our findings are mostly consistent with another recent study, which assesses US respondents' ability to infer the Trump/Clinton vote choices of profiles that as they reveal a mix of social/demographic characteristics as well as political attitudes [@carlson2021experimental].  Like their study, we find that individual-level assessments are noisy but that there are not major biases in those assessments.  The inclusion of political attitudes (e.g. on abortion and partisanship) in the Carlson and Hill experiment means that their study answers a different question than ours.  They find partisanship is the attribute that most increased the accuracy of guesses, followed by the profile's reported most important problem. While closely related methodologically, their experiment is designed to assess respondents' beliefs about the links between other individuals’ political attitudes and vote choice, while ours is focused on the perceived links between social groups and political positions.

As @ahler2020typecast observe, there are a number of mechanisms that could explain errors in citizens' reported beliefs, some of which involve consistently mistaken beliefs and some of which involve different internal logical inconsistencies in citizens' beliefs.  In the conclusion, we suggest future research strategies for resolving some of the outstanding puzzles in this area, using a combination of the research design that we employ here along with those previously employed by Ahler and Sood.



# The Role of Citizens' Perceptions of Group Political Behaviour

Why does it matter what citizens believe about the demographic patterns of voting?  The substantial cognitive and informational demands placed on citizens by democratic institutions have led to a number of theories about the mechanisms through which they process these demands.  Political sophistication is often defined as the ability to deploy political knowledge to make connections with other forms of knowledge [@luskin1987measuring; @luskin1990explaining]. One early articulation envisions citizens holding different 'levels of sophistication', varying according to their ability to recognize and judge social groups and the ideology associated with different political parties [@campbell1960american;@converse1964nature]. In this definition, citizens with higher levels of sophistication are those capable of making ideological judgements, while people with more moderate sophistication are those who perceive parties in a group-centric fashion, as representing a coalition of groups' interests. There is a body of literature that finds most citizens perceive politics in a more group-centred fashion than an ideological one [@converse1964nature;@kinder2017neither;@kalmoe2019speaking], with a general conclusion that "people are naturally more group-oriented than ideological and that, in any case, most 'ideologues' are probably familiar with the groups comprising each party's coalition" [@kalmoe2019speaking]. 

Within the group-centric perspective, @campbell1960american differentiated between those who, when evaluating parties, only mention a single group and those who can reference multiple groups in conflict. In other words, it is possible that a more complex group-centric perspective is also related to higher sophistication. Group-centric perspectives can vary widely in their 'sophistication' according to their accuracy and the extent to which they encompass multiple, potentially overlapping, social groupings. Indeed, there are several academic (presumably sophisticated) perspectives on parties which envision them primarily as group-based coalitions, in which different interest groups come together to coordinate policy demands [@cohen2009party;@bawn2012theory]. From this perspective: "...while parties include ideological elements, collections of intense policy demanding groups define parties" [@kalmoe2019speaking]. 

Partisanship is often conceptualized in the literature as way to ease decisions by giving cues or heuristic guidance for people, with relatively little need for information on the candidates and the electoral context [e.g. @fiorina2002parties]. These cues are usually thought of as policy stances of the party and its candidates, but they may as well be cues on the social groupings of party members. -->    


## Opinion-based Identity and Brexit

While voting and support for political parties are often the focal political behaviour, we can expect similar patterns for other salient opinion-based divisions [@bliuc2007opinionbased;@mcgarty2009collective].  @hobolt2020divided find that, after the 2016 EU referendum, identification as "Leavers" and "Remainers" became at least as strong as party identities. The socio-demographic determinants of Brexit voting are different from those for the party divide. While age and education are the main predictor of this opinion-based division, "measures of social class (such as income, occupation and housing tenure) continue to matter more for partisan identities than for Brexit identities despite sharp falls in class voting in Britain in recent decades" (p.14). This is consistent with previous research on the determinants of Brexit vote that has found that remain voters tended to hold social liberal values, and also were more likely to be younger and hold more educational qualifications, while leave voters tended to hold social conservative values, and tended to be older and hold fewer educational qualifications [e.g. @alabrese2019who;@goodwin20162016;@dassonneville2016volatile]. There are reasons to believe these social cleavages became increasingly relevant partly because of generational changes in the British electorate, which has become more educated and racially diverse [e.g. @sobolewska2019british].  The Brexit divide seems to rival party in terms of their potential to shape citizens' views about the political alignment of social groups. @hobolt2020divided find that in terms of trait stereotype---positive in-group perception and negative out-group perception---the Brexit divide might be stronger than the partisan divide.

Thus, past research gives us reason to suspect that citizens' own social and political identities and their perceptions of the social and political identities of others are interrelated.  This makes it important to know when perceptions are shaped by real demographic patterns, as well as in which circumstances they overstate or caricature those patterns [@ahler2018parties;@claassen2019which].  At the same time, people hold multiple political identities, and these may mobilize distinct aspects of their social identities.  The existence of a long-standing (but evolving) party system in the UK, alongside the more recent "pseudo-party" system of Brexit vote and identity, provides a unique environment to examine how citizens understand the complex demographic associations with political behaviour.

# Data and Methods

Our experiment consists of presenting real profiles of voter characteristics and then asking respondents to assess (1) which party that individual was likely to have voted for in the 2017 UK election or (2) whether that individual was likely to have voted Leave or Remain in the 2016 UK referendum on EU membership.  The profiles of characteristics presented to respondents were those of individuals randomly selected from the 2017 British Elections face-to-face Survey (BES).[^randomisationdetails]  Because each "treatment profile" corresponds to a real BES respondent, each sampled profile has a true vote choice in both the 2016 referendum and 2017 election, and it is possible to benchmark public perceptions against reality.[^missingvalues]

[^randomisationdetails]: BES respondent profiles were randomly sampled with the probability of sampling proportional to the BES 2017 with result weights (*wt_vote*).  This ensured that the profiles presented to respondents of the experiment were nationally representative of British voters, based on self-reported turnout,[^whynotvalidated] in the 2017 election. These weights are constructed using demographic weights targeted to the voting eligible population and weighting to Great Britain turnout and vote results. Not exactly the same people voted in the 2016 referendum and the 2017 election, so this means that the profiles were slightly unrepresentative with respect to 2016 referendum voters, however not to an extent that is consequential for our purposes.

[^whynotvalidated]: We use the BES weights based on self-reported voting (*wt_vote*) rather than validated voting (*wt_vote_valid*).  The tradeoff in doing so is that while self-reported turnout is overstated, the success of the turnout validation process is 67% and not randomly assigned among those completing the survey.  We elected to have a larger sample of profiles to sample from by using self-reported rather than validated turnout.  While the validated turnout levels are clearly closer to correct for the aggregate turnout levels, our analysis is focused on the probability of voting one way versus the other conditional on age, gender, and other variables.  For the inclusion of “turnout overstaters” to be a substantial problem for our analysis, it would need to be the case that the turnout overstaters had a different stated vote distribution than the validated voters, conditional on those other variables.  Since turnout overstaters are  9% of profiles where validation was successful, these differences would have to be very large to change the benchmark for our analysis noticeably.

[^missingvalues]: Gender and region did not present missing values (they are used for the sampling process). To deal with missing attributes of the voters' profiles, due to non-response, two strategies were followed. For all attributes, apart from ethnicity and religion, missing values were randomly imputed using STATA to fill in missing values using a multivariate imputation through chained equations (MICE). In other words, we imputed multiple variables iteratively via a sequence of univariate imputation models, one for each imputation variable, with fully conditional specifications of prediction equations (mi impute chained command in STATA). This imputation strategy relies on assumptions to model the relationship between variables. Specifically, multiple linear regression was used for age, logistic regression for home status, subjective class, and subjective family class, and ordinal logistic for education and income. Gender, region, and vote (EU referendum vote for Brexit experiment and General Elections vote for the party experiment), where used as predictors. For ethnicity and religion, "unknown" category was included in the experiment as a possible level of these attributes. Figure 1 in the online appendix details missingness patterns before imputation. There are only 3.1% missing values for the Brexit experiment and 3.2% for the parties’ experiment and these are mainly concentrated in the income attribute, which is strongly predicted by other attributes, such as home status. We are therefore confident this imputation does not distort the profiles’ distribution in any consequential way.

This experimental design follows a trend towards the use of more complex survey designs, particularly involving multidimensional randomisations of complex treatments.  The most widely applied such designs are conjoint experiments, which independently randomise a large numbers of attributes  in order to enable estimation of *average marginal component effects* [@hainmueller2014causal].  Our design is not a conjoint experiment, because the attributes are not independently randomised, instead we randomly select full profiles of attributes from a population survey (the BES) using population weights.  This means that the profile attributes we present to respondents are effectively sampled from the population joint distribution of those attributes.

There are two reasons that we do not use a conjoint design here, one of which is general and one of which is specific to our application.  In general, one threat to the external validity of conjoint experiments comes from the potential for the independent randomization distribution to consequentially shape the results [@delacuesta2019improving].  Since the *average marginal component effects* (AMCEs) average over the treatment distribution, an independent distribution may not be innocuous for the external validity of any findings.  One manifestation of this problem is the fact that with independent randomization, implausible or impossible combinations of attributes may occur. The more specific reason that we adopt this design is that, unlike the many conjoint experiments which interrogate voter preferences, in our application there is a right answer.  We know the votes of the individual respondents to the BES; we would not know the votes of hypothetical profiles generated by randomising individual attributes.  

The cost of randomising the attributes at the full profile level, rather than the individual attribute level, is that differences in mean response, comparing all responses to profiles with different attribute levels, lose their causal interpretation (they are no longer unbiased estimators of the AMCEs).  We can, nonetheless, form *model-based* rather than *design-based* estimates of the causal effects of respondents seeing particular attribute levels, through the use of regression.  For the purposes of this experiment, it makes sense to sacrifice having simple experimental comparisons for all attributes in exchange for having a meaningful external benchmark.  Crucially, because the full profiles are themselves randomly assigned to respondents, the design still allows us to assess the causal effects of different attributes appearing in the treatment profiles, subject to modelling assumptions about how the effects of different attributes aggregate.

Our experiment was fielded by YouGov in June 2019. The prompt for the Brexit experiment first asked the respondents to carefully read a table with 10 demographic attributes of the voter.  It then asked the respondent to assign how likely it is this voter voted for either Leave or Remain in a slider (that automatically made sure the sum of the two percentages resulted in 100%).  The slider allowed integer percentage responses from 0 to 100.  The party experiment prompt followed a similar format with the addition of making explicit that the profile voter had cast his or her vote for either Labour or Conservative.  Immediately above the slider, the prompt included a statement that aimed to explain to respondents how the scale works. Specifically, it explained that choosing any value other than 0 or 100% implies uncertainty. For the Brexit experiment, this read "If you indicate 100% for either Leave or Remain, you are saying that you are absolutely sure that a person with these characteristics would have voted for that option.  A response of 50% indicates that a person with these characteristics would be equally likely to have voted Leave or Remain."  

```{r, echo=FALSE,out.width="49%",fig.cap="Survey prompts with example profile for Brexit experiment (left) and party experiment (right).",fig.show='hold',fig.align='center'}
knitr::include_graphics(c("screenshot_brexit.png","screenshot_parties.png"))
``` 

The prompt was repeated three times per respondent with different profiles. The order in which the attributes were listed, and which ends of the slider corresponded to Leave, Remain, Conservative or Labour, were randomised per respondent. 1694 respondents were recruited for the Brexit experiment and 1688 respondents for the party experiment.  We use sample weights provided by YouGov that make the data nationally representative for the British population on standard demographic and past vote variables.  

# Determinants of Respondent Guesses

Figure \ref{guesses_by_true_values} shows the distributions of guessed probabilities for voting Leave versus Remain, or Conservative versus Labour.  Despite our efforts in the survey prompt to make clear that 0% and 100% responses are excessively strong statements, as they imply no uncertainty whatsoever, they remain common responses to the prompt.  

```{r, fig.width=8,fig.height=4,out.width="\\linewidth",echo=FALSE,fig.cap="Distributions of guessed probabilities for voting Leave versus Remain (left), and Conservative versus Labour (right). \\label{guesses_by_true_values}",fig.show='hold',fig.align='center'}

#Distribution of guesses

h0_brexit <- hist(Brexit.Experiment.Clean$profile_Leave,br=seq(-0.5,100.5,1),plot=FALSE)
h0_party <- hist(Parties.Experiment.Clean$profile_Con,br=seq(-0.5,100.5,1),plot=FALSE)

par(mfrow=c(1,2))
plot(h0_brexit, col=rgb(0,0,0,0.75),xlim=c(0,100),ylim=c(0,0.1),xlab="Guessed Probability Leave",main="Brexit Experiment",border=NA,freq=FALSE) 
plot(h0_party, col=rgb(0,0,0,0.75),xlim=c(0,100),ylim=c(0,0.1),xlab="Guessed Probability Conservative",main="Party Experiment",border=NA,freq=FALSE)

``` 


```{r,echo=FALSE}

# Analizing overall precision of guesses

## Brexit


dclus1<-svydesign(ids=~0, weights=Brexit.BES.Clean$profile_weights, data=Brexit.BES.Clean)
propleave<-svyciprop(~I(Leave.BES.01==1),dclus1, method="lo", df=degf(dclus1))
CI.est<-data.frame("fit"=as.matrix(propleave)*100)
CI.low <-data.frame("lwr"=as.matrix(attr(propleave, "ci")[1])*100)
CI.high <-data.frame("upr"=as.matrix(attr(propleave, "ci")[2])*100)
CI.Prop.leave.BES<-data.frame("leave"="BES",CI.est, CI.low,CI.high)

dclus2<-svydesign(ids=~0, weights=Brexit.Experiment.Clean$respondent_weights, data=Brexit.Experiment.Clean)
CI.est<-data.frame("fit"=(svymean(~profile_Leave,  dclus2, level = 0.95, na.rm=T))[1])
CI.low<-data.frame("lwr"=confint(svymean(~profile_Leave,  dclus2, level = 0.95, na.rm=T))[1])
CI.high<-data.frame("upr"=confint(svymean(~profile_Leave,  dclus2, level = 0.95, na.rm=T))[2])
CI.Prop.leave.Guess<-data.frame("leave"="Guess", CI.est, CI.low,CI.high)
rownames(CI.Prop.leave.BES)<- "Leave"

leave.Bind<-bind_rows(CI.Prop.leave.Guess, CI.Prop.leave.BES)

## Parties


dclus1<-svydesign(ids=~0, weights=Parties.BES.Clean$profile_weights, data=Parties.BES.Clean)
propleave<-svyciprop(~I(Con.BES.01==1),dclus1, method="lo", df=degf(dclus1))
CI.est<-data.frame("fit"=as.matrix(propleave)*100)
CI.low <-data.frame("lwr"=as.matrix(attr(propleave, "ci")[1])*100)
CI.high <-data.frame("upr"=as.matrix(attr(propleave, "ci")[2])*100)
CI.Prop.Con.BES<-data.frame("Con"="BES",CI.est, CI.low,CI.high)

dclus2<-svydesign(ids=~0, weights=Parties.Experiment.Clean$respondent_weights, data=Parties.Experiment.Clean)
CI.est<-data.frame("fit"=(svymean(~profile_Con,  dclus2, level = 0.95, na.rm=T))[1])
CI.low<-data.frame("lwr"=confint(svymean(~profile_Con,  dclus2, level = 0.95, na.rm=T))[1])
CI.high<-data.frame("upr"=confint(svymean(~profile_Con,  dclus2, level = 0.95, na.rm=T))[2])
CI.Prop.Con.Guess<-data.frame("Con"="Guess", CI.est, CI.low,CI.high)
rownames(CI.Prop.Con.BES)<- "Con"

Con.Bind<-bind_rows(CI.Prop.Con.Guess, CI.Prop.Con.BES)

```

Because the experimental profiles were randomly sampled from the BES, we can benchmark general perceptions on average across all profiles.  Do respondents accurately perceive the general tendency of voters in the UK to support Labour versus the Conservatives and Leave versus Remain?  The average guess for the party experiment is `r round(Con.Bind[1,2],1)`% Conservative vote (95% interval `r round(Con.Bind[1,3],1)`-`r round(Con.Bind[1,4],1)`), slightly lower than the true value of `r round(100*13636684/(13636684+12878460),1)`% of the two-party vote and the proportion of the BES profiles which corresponded to Conservative voters, which was `r round(Con.Bind[2,2],1)`% (95% interval `r round(Con.Bind[2,3],1)`-`r round(Con.Bind[2,4],1)`).  In the Brexit experiment, the overall average guess is `r round(leave.Bind[1,2],1)`% Leave vote (95% interval `r round(leave.Bind[1,3],1)`-`r round(leave.Bind[1,4],1)`), which is slightly greater than both the true value of `r round(100*17410742/(17410742+16141241),1)`% and the proportion of the BES profiles which corresponded to Leave voters, which was `r round(leave.Bind[2,2],1)`% (95% interval `r round(leave.Bind[2,3],1)`-`r round(leave.Bind[2,4],1)`).[^BESweights]  While these differences are statistically significant, they are not substantively large.

[^BESweights]: The BES estimates for our Brexit experiment are slightly smaller than the referendum result because the sample is weighted to correspond to general election voters rather than those who voted in the referendum. Thus, on average, respondents perceived profiles as being more likely to correspond to Leave voters than they ought to have, and were very close to accurate for Remain voters.

## Differences in Mean Guesses By Respondent Vote and Profile Vote


```{r,include=FALSE}

#Analyzing the overall precision of guesses by true vote of profile 

Means.Guess.by.TrueVote.Con<-lm(profile_Con~as.factor(profile_Conservative.Real)-1, data=Parties.Experiment.Clean,  w=Parties.Experiment.Clean$respondent_weights)
Means.Guess.by.TrueVote.Leave<-lm(profile_Leave~as.factor(profile_Leave.Real)-1, data=Brexit.Experiment.Clean,  w=Brexit.Experiment.Clean$respondent_weights)

```

As an initial check on whether respondents are able to distinguish at all between Leave and Remain or Conservative and Labour profiles, we can calculate the average response given the true votes of the profiles that respondents observed.  We find that the average guessed probability of a Leave vote was `r round(coef(Means.Guess.by.TrueVote.Leave)[1],1)` (`r round(confint(Means.Guess.by.TrueVote.Leave)[1,1],1)`%-`r round(confint(Means.Guess.by.TrueVote.Leave)[1,2],1)`%) for BES profiles that actually voted for Remain, and `r round(coef(Means.Guess.by.TrueVote.Leave)[2],1)` (`r round(confint(Means.Guess.by.TrueVote.Leave)[2,1],1)`%-`r round(confint(Means.Guess.by.TrueVote.Leave)[2,2],1)`%) for those that actually voted for Leave.  We find that the average guessed probability of a Conservative vote was `r round(coef(Means.Guess.by.TrueVote.Con)[1],1)` (`r round(confint(Means.Guess.by.TrueVote.Con)[1,1],1)`%-`r round(confint(Means.Guess.by.TrueVote.Con)[1,2],1)`%) for BES profiles that actually voted Labour, and `r round(coef(Means.Guess.by.TrueVote.Con)[2],1)` (`r round(confint(Means.Guess.by.TrueVote.Con)[2,1],1)`%-`r round(confint(Means.Guess.by.TrueVote.Con)[2,2],1)`%) for those profiles that actually voted  Conservative.  Thus, we see clear evidence that responses were, on average, affected by information in the profiles in a way that made them more accurate than would have occurred if respondents were guessing without reference to the profile.  They were more likely to guess higher probabilities of a Leave vote when the profile really was a Leave voter rather than a Remain voter; they were more likely to guess higher probabilities of a Conservative vote when the profile really was a Conservative voter rather than a Labour voter.  

```{r,include=FALSE}

#Analyzing the presence of egotistic bias (guesses by previous vote of respondent)

Means.Guess.by.Vote.Con<-lm(profile_Con~respondent_pastvote_2017, data=Parties.Experiment.Clean,  w=Parties.Experiment.Clean$respondent_weights)
new.dat<-data.frame(respondent_pastvote_2017=factor(c("Conservative","Labour", "Liberal Democrat",
 "Scottish National Party (SNP)", "Plaid Cymru","UK Independence Party (UKIP)","Green")))
Means.Guess.by.Vote.Con1<-data.frame(new.dat, predict(Means.Guess.by.Vote.Con, newdata = new.dat, interval = 'confidence'))

Means.Guess.by.Vote.Con1$respondent_pastvote_2017<-factor(Means.Guess.by.Vote.Con1$respondent_pastvote_2017, levels=Means.Guess.by.Vote.Con1$respondent_pastvote_2017[order(Means.Guess.by.Vote.Con1$fit)])

Means.Guess.by.Vote.Leave<-lm(profile_Leave~respondent_pastvote_EURef, data=Brexit.Experiment.Clean,  w=Brexit.Experiment.Clean$respondent_weights)
new.dat<-data.frame(respondent_pastvote_EURef=factor(c("Remain", "Leave",  "Did not vote")))
Means.Guess.by.Vote.Leave1<-data.frame(new.dat, predict(Means.Guess.by.Vote.Leave, newdata = new.dat, interval = 'confidence'))
Means.Guess.by.Vote.Leave1$respondent_pastvote_EURef<-factor(Means.Guess.by.Vote.Leave1$respondent_pastvote_EURef, levels=Means.Guess.by.Vote.Leave1$respondent_pastvote_EURef[order(Means.Guess.by.Vote.Leave1$fit)])

Means.Guess.by.Vote.Con1 <- Means.Guess.by.Vote.Con1 %>%
  mutate(respondent_pastvote_2017 =
                  recode(respondent_pastvote_2017,
         "Scottish National Party (SNP)" = "Scottish National\nParty (SNP)",  "UK Independence Party (UKIP)" = "UK Independence\nParty (UKIP)"))

guess.by.Brexit.vote<-ggplot(Means.Guess.by.Vote.Leave1, aes(x=respondent_pastvote_EURef, y=fit)) + 
  geom_errorbar(aes(ymin=lwr, ymax=upr), width=.1, position= position_dodge(w=0.5)) +
  geom_point(position= position_dodge(w=0.5), shape=19, size=2, color="red", alpha=0.7) +
  geom_hline(yintercept=51.9, linetype="dashed", 
             size=1, color="blue", alpha=0.5)+
  ylim(0, 100) +
  theme_clean()+ 
  ggtitle("Leave Vote Guess by Previous EU Referendum Vote") + theme(plot.title = element_text(hjust = 0.5)) +
  xlab("") + ylab("")+ theme(legend.position="bottom", axis.text=element_text(size=10))+
  coord_flip()

guess.by.party.vote<-ggplot(Means.Guess.by.Vote.Con1, aes(x=respondent_pastvote_2017, y=fit)) + 
  geom_errorbar(aes(ymin=lwr, ymax=upr), width=.1, position= position_dodge(w=0.5)) +
  geom_point(position= position_dodge(w=0.5), shape=19, size=2, color="red", alpha=0.7) +
  geom_hline(yintercept=51.4, linetype="dashed", 
             size=1, color="blue", alpha=0.5)+
  ylim(0, 100) +
  theme_clean()+ 
  ggtitle("Conservative Vote Guess by Previous General Election Vote") + theme(plot.title = element_text(hjust = 0.5)) +
  xlab("") + ylab("")+ theme(legend.position="bottom", axis.text=element_text(size=10))+
  coord_flip()

```

We can ask a similar question with respect to respondents' own vote history.  Since the treatment profiles are randomly assigned to respondents, any difference that we see as a function of respondents' own vote history must be an indication of bias in how respondents perceive the votes of other citizens.  We find that for both the party experiment and Brexit experiment there are small, but statistically significant differences predicted by respondents' previous vote. In the party experiment we find that respondents that voted for Labour in the 2017 general election underestimated the probabilities of Conservative vote, with an average guess of `r round(Means.Guess.by.Vote.Con1[2,2],1)`% (95% interval `r round(Means.Guess.by.Vote.Con1[2,3],1)`-`r round(Means.Guess.by.Vote.Con1[2,4],1)`) while respondents who voted for Conservative were, on average, unbiased in their guesses, with an average guess of `r round(Means.Guess.by.Vote.Con1[1,2],1)`% (95% interval `r round(Means.Guess.by.Vote.Con1[1,3],1)`-`r round(Means.Guess.by.Vote.Con1[1,4],1)`).
In the referendum experiment, all respondents tended to overestimate Leave vote. However, this bias was stronger among leave voters, with an average of `r round(Means.Guess.by.Vote.Leave1[2,2],1)`% (95% interval `r round(Means.Guess.by.Vote.Leave1[2,3],1)`-`r round(Means.Guess.by.Vote.Leave1[2,4],1)`) versus an average of `r round(Means.Guess.by.Vote.Leave1[1,2],1)`% (95% interval `r round(Means.Guess.by.Vote.Leave1[1,3],1)`-`r round(Means.Guess.by.Vote.Leave1[1,4],1)`) for those who voted remain.
While both experiments provide evidence of a tendency for respondents to make guesses about the profiles that tend slightly towards their own positions, the differences in average guess by respondents' own votes are still smaller than the differences by the profile's true vote.[^ownvote]  

[^ownvote]: This may seem like a low standard, but respondents know their own vote and not the profile vote.

## Differences in Mean Guesses By Profile Attribute

Because the profiles in our experiment are drawn from the real joint distribution of voters, we can analyse accuracy, subsetting by profile attribute values and comparing to the BES.  The cross-tabulated BES distributions of vote by these attributes provide an appropriate benchmark for actual voting behaviour among individuals with these attributes, averaging over the actual distributions of other attributes that tend to come along with the attribute we are focusing on.  Thus, for example, we can compare the guessed proportion of Leave voters for profiles with a university degree in the experiment (*"Guess"*) to the proportion of Leave voters among (weighted) BES respondents (*"BES"*) with a university degree.  We are additionally able to compare to the true result of the election/referendum (*"Real"*) when we subset by region.

Note that while it facilitates benchmarking, the non-independent randomization of profile attributes means that we cannot conclude from this analysis that it was a specific grouping variable that *caused* respondents to guess differently with respect to vote.  It could be that it was other attributes, themselves associated with that attribute in the UK population, which led respondents to make different guesses.  

```{r,include=FALSE}

#The following chunk allows for comparisons of mean guess by profile attribute with the same mean in the BES

# Predicting the (weighted) mean guess by level of each attribute

MeansAge<-lm(profile_Leave~profile_AgeGroup, data=Brexit.Experiment.Clean,  w=Brexit.Experiment.Clean$respondent_weights)
levels(Brexit.Experiment.Clean$profile_AgeGroup)
new.dat <- data.frame(profile_AgeGroup=c("18-29", "30-44", "45-59", "60-74", "75 +"))
MeansAge1<-data.frame(new.dat, predict(MeansAge, newdata = new.dat, interval = 'confidence'))
MeansAgeBES<-lm(profile_Leave~profile_AgeGroup, data=Brexit.BES.Clean,  w=Brexit.BES.Clean$profile_weights)
MeansAgeBES2<-data.frame(new.dat, predict(MeansAgeBES, newdata = new.dat, interval = 'confidence'))

MeansAgeBES2$Probabilities<-"BES"
MeansAge1$Probabilities<-"Guess"
MeansAge.Bind<-bind_rows(MeansAge1, MeansAgeBES2)

MeansReligion<-lm(profile_Leave~profile_Religion, data=Brexit.Experiment.Clean,  w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Religion=c("Roman Catholic","Church of England/Anglican/Episcopal",
                                 "Hindu","Islam",
                                 "Methodist","Presbyterian/Church of Scotland",
                                 "No religion","Unknown" ))
MeansReligion1<-data.frame(new.dat, predict(MeansReligion, newdata = new.dat, interval = 'confidence'))
MeansReligion1$profile_Religion<-factor(MeansReligion1$profile_Religion, levels=MeansReligion1$profile_Religion[order(MeansReligion1$fit)])
MeansReligionBES<-lm(profile_Leave~profile_Religion, data=Brexit.BES.Clean,  w=Brexit.BES.Clean$profile_weights)
MeansReligionBES2<-data.frame(new.dat, predict(MeansReligionBES, newdata = new.dat, interval = 'confidence'))

MeansReligionBES2$Probabilities<-"BES"
MeansReligion1$Probabilities<-"Guess"
MeansReligion.Bind<-bind_rows(MeansReligion1, MeansReligionBES2)


MeansEthnicity<-lm(profile_Leave~profile_Ethnicity, data=Brexit.Experiment.Clean,  w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Ethnicity=c("Asian","Black",                            
                                  "Mixed","White",                            
                                  "Unknown"))
MeansEthnicity1<-data.frame(new.dat, predict(MeansEthnicity, newdata = new.dat, interval = 'confidence'))
MeansEthnicity1$profile_Ethnicity<-factor(MeansEthnicity1$profile_Ethnicity, levels=MeansEthnicity1$profile_Ethnicity[order(MeansEthnicity1$fit)])
MeansEthnicityBES<-lm(profile_Leave~profile_Ethnicity, data=Brexit.BES.Clean,  w=Brexit.BES.Clean$profile_weights)
MeansEthnicityBES2<-data.frame(new.dat, predict(MeansEthnicityBES, newdata = new.dat, interval = 'confidence'))


MeansEthnicityBES2$Probabilities<-"BES"
MeansEthnicity1$Probabilities<-"Guess"
MeansEthnicity.Bind<-bind_rows(MeansEthnicity1, MeansEthnicityBES2)


MeansGender<-lm(profile_Leave~profile_Gender, data=Brexit.Experiment.Clean,  w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Gender=c("Male", "Female"))
MeansGender1<-data.frame(new.dat, predict(MeansGender, newdata = new.dat, interval = 'confidence'))
MeansGenderBES<-lm(profile_Leave~profile_Gender, data=Brexit.BES.Clean,  w=Brexit.BES.Clean$profile_weights)
MeansGenderBES2<-data.frame(new.dat, predict(MeansGenderBES, newdata = new.dat, interval = 'confidence'))

MeansGenderBES2$Probabilities<-"BES"
MeansGender1$Probabilities<-"Guess"
MeansGender.Bind<-bind_rows(MeansGender1, MeansGenderBES2)

MeansEducation2<-lm(profile_Leave~profile_Education, data=Brexit.Experiment.Clean,  w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Education=c('Holds a university degree', 'Does not hold a university degree'))
MeansEducation3<-data.frame(new.dat, predict(MeansEducation2, newdata = new.dat, interval = 'confidence'))
MeansEducationBES<-lm(profile_Leave~profile_Education, data=Brexit.BES.Clean,  w=Brexit.BES.Clean$profile_weights)
MeansEducationBES2<-data.frame(new.dat, predict(MeansEducationBES, newdata = new.dat, interval = 'confidence'))

MeansEducationBES2$Probabilities<-"BES"
MeansEducation3$Probabilities<-"Guess"
MeansEducation.Bind<-bind_rows(MeansEducation3, MeansEducationBES2)

MeansRegion<-lm(profile_Leave~profile_Region, data=Brexit.Experiment.Clean,  w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Region=factor(c("London", "North East",
                                              "North West","Scotland",
                                              "South East","South West",
                                              "the East Midlands","the East of England",
                                              "Wales","West Midlands",
                                              "Yorkshire & Humber")))
MeansRegion1<-data.frame(new.dat, predict(MeansRegion, newdata = new.dat, interval = 'confidence'))
MeansRegion1$profile_Region<-factor(MeansRegion1$profile_Region, levels=MeansRegion1$profile_Region[order(MeansRegion1$fit)])
MeansRegionBES<-lm(profile_Leave~profile_Region, data=Brexit.BES.Clean,  w=Brexit.BES.Clean$profile_weights)
MeansRegionBES2<-data.frame(new.dat, predict(MeansRegionBES, newdata = new.dat, interval = 'confidence'))
MeansRegionBES2$Probabilities<-"BES"
MeansRegion1$Probabilities<-"Guess"
MeansRegion.Bind<-bind_rows(MeansRegion1, MeansRegionBES2)


MeansRegion.Bind<-bind_rows(MeansRegion1, MeansRegionBES2)
Realvote<-Brexit.Experiment.Clean %>%
dplyr::  group_by(profile_Region) %>%
  dplyr::   summarise(fit = mean(profile_regional_real_Leave, na.rm=T))
Realvote$Probabilities<-"Real"

MeansRegion.Bind2<-bind_rows(MeansRegion.Bind, Realvote)
MeansRegion.Bind2$Probabilities<-factor(MeansRegion.Bind2$Probabilities,
       levels=c("BES"[order(1)],"Real"[order(2)],"Guess"[order(3)]))


MeansIncome<-lm(profile_Leave~profile_AnnualHouseholdIncome, data=Brexit.Experiment.Clean, w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_AnnualHouseholdIncome=factor(c("Less than 5,199"[order(1)],
                                                             "Between 5,200 and 15,599"[order(2)],
                                                             "Between 15,600 and 25,999"[order(3)],
                                                             "Between 26,000 and 36,399"[order(4)],
                                                             "Between 36,400 and 44,999"[order(5)],
                                                             "Between 45,000 and 59,999"[order(6)],
                                                             "Between 60,000 and 99,999"[order(7)],
                                                             "Greater than 100,000"[order(8)] )))

MeansIncome2<-data.frame(new.dat, predict(MeansIncome, newdata = new.dat, interval = 'confidence'))
MeansIncomeBES<-lm(profile_Leave~profile_AnnualHouseholdIncome, data=Brexit.BES.Clean,  w=Brexit.BES.Clean$profile_weights)
MeansIncomeBES2<-data.frame(new.dat, predict(MeansIncomeBES, newdata = new.dat, interval = 'confidence'))

MeansIncomeBES2$Probabilities<-"BES"
MeansIncome2$Probabilities<-"Guess"
MeansIncome.Bind<-bind_rows(MeansIncome2, MeansIncomeBES2)

MeansIncome.Bind$profile_AnnualHouseholdIncome<-factor(MeansIncome.Bind$profile_AnnualHouseholdIncome,
                                                       levels = c("Less than 5,199"[order(1)],
                                                             "Between 5,200 and 15,599"[order(2)],
                                                             "Between 15,600 and 25,999"[order(3)],
                                                             "Between 26,000 and 36,399"[order(4)],
                                                             "Between 36,400 and 44,999"[order(5)],
                                                             "Between 45,000 and 59,999"[order(6)],
                                                             "Between 60,000 and 99,999"[order(7)],
                                                             "Greater than 100,000"[order(8)] ))

MeansClass<-lm(profile_Leave~profile_SubClass, data=Brexit.Experiment.Clean,  w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_SubClass=c("Working class", "Middle class"))
MeansClass1<-data.frame(new.dat, predict(MeansClass, newdata = new.dat, interval = 'confidence'))
MeansClassBES<-lm(profile_Leave~profile_SubClass, data=Brexit.BES.Clean,  w=Brexit.BES.Clean$profile_weights)
MeansClassBES2<-data.frame(new.dat, predict(MeansClassBES, newdata = new.dat, interval = 'confidence'))

MeansClassBES2$Probabilities<-"BES"
MeansClass1$Probabilities<-"Guess"
MeansClass.Bind<-bind_rows(MeansClass1, MeansClassBES2)

MeansFamClass<-lm(profile_Leave~profile_SubFamClass, data=Brexit.Experiment.Clean,  w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_SubFamClass=c("Family working class", "Family middle class"))
MeansFamClass1<-data.frame(new.dat, predict(MeansFamClass, newdata = new.dat, interval = 'confidence'))
MeansFamClassBES<-lm(profile_Leave~profile_SubFamClass, data=Brexit.BES.Clean,  w=Brexit.BES.Clean$profile_weights)
MeansFamClassBES2<-data.frame(new.dat, predict(MeansFamClassBES, newdata = new.dat, interval = 'confidence'))

MeansFamClassBES2$Probabilities<-"BES"
MeansFamClass1$Probabilities<-"Guess"
MeansFamClass.Bind<-bind_rows(MeansFamClass1, MeansFamClassBES2)


MeansHomeStatus<-lm(profile_Leave~profile_HomeStatus, data=Brexit.Experiment.Clean,  w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_HomeStatus=c("Rents home", "Owns home"))
MeansHomeStatus1<-data.frame(new.dat, predict(MeansHomeStatus, newdata = new.dat, interval = 'confidence'))
MeansHomeStatusBES<-lm(profile_Leave~profile_HomeStatus, data=Brexit.BES.Clean,  w=Brexit.BES.Clean$profile_weights)
MeansHomeStatusBES2<-data.frame(new.dat, predict(MeansHomeStatusBES, newdata = new.dat, interval = 'confidence'))

MeansHomeStatusBES2$Probabilities<-"BES"
MeansHomeStatus1$Probabilities<-"Guess"
MeansHomeStatus.Bind<-bind_rows(MeansHomeStatus1, MeansHomeStatusBES2)


#Parties

MeansAge<-lm(profile_Con~profile_AgeGroup, data=Parties.Experiment.Clean,  w=Parties.Experiment.Clean$respondent_weights)
levels(Parties.Experiment.Clean$profile_AgeGroup)
new.dat <- data.frame(profile_AgeGroup=c("18-29", "30-44", "45-59", "60-74", "75 +"))
MeansAge1<-data.frame(new.dat, predict(MeansAge, newdata = new.dat, interval = 'confidence'))
MeansAgeBES<-lm(profile_Con~profile_AgeGroup, data=Parties.BES.Clean,  w=Parties.BES.Clean$profile_weights)
MeansAgeBES2<-data.frame(new.dat, predict(MeansAgeBES, newdata = new.dat, interval = 'confidence'))

MeansAgeBES2$Probabilities<-"BES"
MeansAge1$Probabilities<-"Guess"
MeansAgeP.Bind<-bind_rows(MeansAge1, MeansAgeBES2)

MeansEducationP<-lm(profile_Con~profile_Education, data=Parties.Experiment.Clean,  w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Education=c('Holds a university degree', 'Does not hold a university degree'))
MeansEducationP2<-data.frame(new.dat, predict(MeansEducationP, newdata = new.dat, interval = 'confidence'))
MeansEducationPBES<-lm(profile_Con~profile_Education, data=Parties.BES.Clean,  w=Parties.BES.Clean$profile_weights)
MeansEducationPBES2<-data.frame(new.dat, predict(MeansEducationPBES, newdata = new.dat, interval = 'confidence'))

MeansEducationPBES2$Probabilities<-"BES"
MeansEducationP2$Probabilities<-"Guess"
MeansEducationP.Bind<-bind_rows(MeansEducationP2, MeansEducationPBES2)


MeansIncomeP<-lm(profile_Con~profile_AnnualHouseholdIncome, data=Parties.Experiment.Clean,  w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame((profile_AnnualHouseholdIncome=factor(c("Less than 5,199"[order(1)],
                                                             "Between 5,200 and 15,599"[order(2)],
                                                             "Between 15,600 and 25,999"[order(3)],
                                                             "Between 26,000 and 36,399"[order(4)],
                                                             "Between 36,400 and 44,999"[order(5)],
                                                             "Between 45,000 and 59,999"[order(6)],
                                                             "Between 60,000 and 99,999"[order(7)],
                                                             "Greater than 100,000"[order(8)]))))

MeansIncomeP2<-data.frame(new.dat, predict(MeansIncomeP, newdata = new.dat, interval = 'confidence'))
MeansIncomePBES<-lm(profile_Con~profile_AnnualHouseholdIncome, data=Parties.BES.Clean,  w=Parties.BES.Clean$profile_weights)
MeansIncomePBES2<-data.frame(new.dat, predict(MeansIncomePBES, newdata = new.dat, interval = 'confidence'))


MeansIncomePBES2$Probabilities<-"BES"
MeansIncomeP2$Probabilities<-"Guess"
MeansIncomeP.Bind<-bind_rows(MeansIncomeP2, MeansIncomePBES2)

MeansIncomeP.Bind$profile_AnnualHouseholdIncome<-factor(MeansIncome.Bind$profile_AnnualHouseholdIncome,
                                                       levels = c("Less than 5,199"[order(1)],
                                                             "Between 5,200 and 15,599"[order(2)],
                                                             "Between 15,600 and 25,999"[order(3)],
                                                             "Between 26,000 and 36,399"[order(4)],
                                                             "Between 36,400 and 44,999"[order(5)],
                                                             "Between 45,000 and 59,999"[order(6)],
                                                             "Between 60,000 and 99,999"[order(7)],
                                                             "Greater than 100,000"[order(8)] ))



MeansRegionP<-lm(profile_Con~profile_Region, data=Parties.Experiment.Clean,  w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Region=factor(c("London", "North East",
                                              "North West","Scotland",
                                              "South East","South West",
                                              "the East Midlands","the East of England",
                                              "Wales","West Midlands",
                                              "Yorkshire & Humber")))
MeansRegionP1<-data.frame(new.dat, predict(MeansRegionP, newdata = new.dat, interval = 'confidence'))
MeansRegionP1$profile_Region<-factor(MeansRegionP1$profile_Region, levels=MeansRegionP1$profile_Region[order(MeansRegionP1$fit)])
MeansRegionPBES<-lm(profile_Con~profile_Region, data=Parties.BES.Clean,  w=Parties.BES.Clean$profile_weights)
MeansRegionPBES2<-data.frame(new.dat, predict(MeansRegionPBES, newdata = new.dat, interval = 'confidence'))


MeansRegionPBES2$Probabilities<-"BES"
MeansRegionP1$Probabilities<-"Guess"
MeansRegionP.Bind<-bind_rows(MeansRegionP1, MeansRegionPBES2)
Realvote<-Parties.Experiment.Clean %>%
dplyr::  group_by(profile_Region) %>%
  dplyr::   summarise(fit = mean(profile_regional_real_Con, na.rm=T))
Realvote$Probabilities<-"Real"

MeansRegionP2.Bind<-bind_rows(MeansRegionP.Bind, Realvote)
MeansRegionP2.Bind$Probabilities<-factor(MeansRegion.Bind2$Probabilities,
       levels=c("BES"[order(1)],"Real"[order(2)],"Guess"[order(3)]))


MeansClassP<-lm(profile_Con~profile_SubClass, data=Parties.Experiment.Clean,  w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_SubClass=c("Working class", "Middle class"))
MeansClassP1<-data.frame(new.dat, predict(MeansClassP, newdata = new.dat, interval = 'confidence'))
MeansClassPBES<-lm(profile_Con~profile_SubClass, data=Parties.BES.Clean,  w=Parties.BES.Clean$profile_weights)
MeansClassPBES2<-data.frame(new.dat, predict(MeansClassPBES, newdata = new.dat, interval = 'confidence'))

MeansClassPBES2$Probabilities<-"BES"
MeansClassP1$Probabilities<-"Guess"
MeansClassP.Bind<-bind_rows(MeansClassP1, MeansClassPBES2)


MeansFamClassP<-lm(profile_Con~profile_SubFamClass, data=Parties.Experiment.Clean,  w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_SubFamClass=c("Family working class", "Family middle class"))
MeansFamClassP1<-data.frame(new.dat, predict(MeansFamClassP, newdata = new.dat, interval = 'confidence'))
MeansFamClassPBES<-lm(profile_Con~profile_SubFamClass, data=Parties.BES.Clean,  w=Parties.BES.Clean$profile_weights)
MeansFamClassPBES2<-data.frame(new.dat, predict(MeansFamClassPBES, newdata = new.dat, interval = 'confidence'))

MeansFamClassPBES2$Probabilities<-"BES"
MeansFamClassP1$Probabilities<-"Guess"
MeansFamClassP.Bind<-bind_rows(MeansFamClassP1, MeansFamClassPBES2)

MeansHomeStatusP<-lm(profile_Con~profile_HomeStatus, data=Parties.Experiment.Clean,  w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_HomeStatus=c("Rents home", "Owns home"))
MeansHomeStatusP1<-data.frame(new.dat, predict(MeansHomeStatusP, newdata = new.dat, interval = 'confidence'))
MeansHomeStatusPBES<-lm(profile_Con~profile_HomeStatus, data=Parties.BES.Clean,  w=Parties.BES.Clean$profile_weights)
MeansHomeStatusPBES2<-data.frame(new.dat, predict(MeansHomeStatusPBES, newdata = new.dat, interval = 'confidence'))

MeansHomeStatusPBES2$Probabilities<-"BES"
MeansHomeStatusP1$Probabilities<-"Guess"
MeansHomeStatusP.Bind<-bind_rows(MeansHomeStatusP1, MeansHomeStatusPBES2)


MeansReligionP<-lm(profile_Con~profile_Religion, data=Parties.Experiment.Clean,  w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Religion=c("Roman Catholic","Church of England/Anglican/Episcopal",
                                 "Hindu","Islam",
                                 "Methodist","Presbyterian/Church of Scotland",
                                 "No religion","Unknown" ))
MeansReligionP1<-data.frame(new.dat, predict(MeansReligionP, newdata = new.dat, interval = 'confidence'))
MeansReligionP1$profile_Religion<-factor(MeansReligionP1$profile_Religion, levels=MeansReligionP1$profile_Religion[order(MeansReligionP1$fit)])
MeansReligionPBES<-lm(profile_Con~profile_Religion, data=Parties.BES.Clean,  w=Parties.BES.Clean$profile_weights)
MeansReligionPBES2<-data.frame(new.dat, predict(MeansReligionPBES, newdata = new.dat, interval = 'confidence'))

MeansReligionPBES2$Probabilities<-"BES"
MeansReligionP1$Probabilities<-"Guess"
MeansReligionP.Bind<-bind_rows(MeansReligionP1, MeansReligionPBES2)


MeansEthnicityP<-lm(profile_Con~profile_Ethnicity, data=Parties.Experiment.Clean,  w=Parties.Experiment.Clean$respondent_weights)
new.dat<-data.frame(profile_Ethnicity=factor(c("Asian","Black",                            
                                       "Mixed","White",                            
                                       "Unknown")))
MeansEthnicityP1<-data.frame(new.dat, predict(MeansEthnicityP, newdata = new.dat, interval = 'confidence'))
MeansEthnicityP1$profile_Ethnicity<-factor(MeansEthnicityP1$profile_Ethnicity, levels=MeansEthnicityP1$profile_Ethnicity[order(MeansEthnicityP1$fit)])
MeansEthnicityPBES<-lm(profile_Con~profile_Ethnicity, data=Parties.BES.Clean,  w=Parties.BES.Clean$profile_weights)
MeansEthnicityPBES2<-data.frame(new.dat, predict(MeansEthnicityPBES, newdata = new.dat, interval = 'confidence'))

MeansEthnicityPBES2$Probabilities<-"BES"
MeansEthnicityP1$Probabilities<-"Guess"
MeansEthnicityP.Bind<-bind_rows(MeansEthnicityP1, MeansEthnicityPBES2)


MeansGenderP<-lm(profile_Con~profile_Gender, data=Parties.Experiment.Clean,  w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Gender=c("Male", "Female"))
MeansGenderP1<-data.frame(new.dat, predict(MeansGenderP, newdata = new.dat, interval = 'confidence'))
MeansGenderPBES<-lm(profile_Con~profile_Gender, data=Parties.BES.Clean,  w=Parties.BES.Clean$profile_weights)
MeansGenderPBES2<-data.frame(new.dat, predict(MeansGenderPBES, newdata = new.dat, interval = 'confidence'))

MeansGenderPBES2$Probabilities<-"BES"
MeansGenderP1$Probabilities<-"Guess"
MeansGenderP.Bind<-bind_rows(MeansGenderP1, MeansGenderPBES2)


### COMBINE INTO ONE BIG PLOT FOR EACH EXPERIMENT

relabel_for_single_plot <- function(df) {
  df[,1] <- paste0(colnames(df)[1],": ",df[,1])
  colnames(df)[1] <- "Group"
  return(df)
}

# tidy labels
colnames(MeansIncome.Bind)[1] <- "Income"

MeansAll.Bind <- rbind(
relabel_for_single_plot(MeansAge.Bind),  
relabel_for_single_plot(MeansGender.Bind),
relabel_for_single_plot(MeansEthnicity.Bind),
relabel_for_single_plot(MeansEducation.Bind),
relabel_for_single_plot(MeansHomeStatus.Bind),
relabel_for_single_plot(MeansClass.Bind),
relabel_for_single_plot(MeansFamClass.Bind),
relabel_for_single_plot(MeansRegion.Bind2),
relabel_for_single_plot(MeansIncome.Bind),
relabel_for_single_plot(MeansReligion.Bind)
)
MeansAll.Bind$Group<- gsub("profile_", "",MeansAll.Bind$Group)

MeansAll.Bind <- MeansAll.Bind %>%
  tidyr::separate(Group, into = c("Group", "Attribute"), sep=": ")

MeansAll.Bind<- MeansAll.Bind %>%
  mutate(Attribute = fct_reorder(Attribute, fit))
MeansAll.Bind<- MeansAll.Bind %>%
  mutate(Attribute = fct_relevel(Attribute,"Unknown", "Less than 5,199", "Between 5,200 and 15,599","Between 15,600 and 25,999", "Between 26,000 and 36,399", "Between 36,400 and 44,999",  "Between 45,000 and 59,999", "Between 60,000 and 99,999", "Greater than 100,000"))

MeansAll.Bind<- MeansAll.Bind %>%
  mutate(Group = dplyr::recode(Group, HomeStatus = "Home Status", AgeGroup = "Age", SubClass= "Class", SubFamClass = "Family Class"))

P_All_Brex <- ggplot(MeansAll.Bind, aes(x = Attribute, y=fit, col = Probabilities, shape = Probabilities)) + 
  geom_errorbar(aes(ymin=lwr, ymax=upr), width=.1, position= position_dodge(w=0.5)) +
  geom_point(position= position_dodge(w=0.5), size=2) +
  geom_hline(yintercept=50, linetype="dashed", 
             size=1, color="grey", alpha=0.5)+
  theme_classic()+
  ggtitle("Vote Leave by Group") + theme(plot.title = element_text(hjust = 0.5)) +
  xlab("") + ylab("")+
  facet_grid(Group~., scales = "free_y", space = "free_y")+
  theme(legend.position="bottom", strip.text.y =element_text(angle = 0),
        panel.grid.major.y = element_line(colour = "grey95"),
        panel.background = element_rect(colour = "black"))+
  coord_flip(ylim= c(0, 100))+
  scale_color_manual(values = c("dodgerblue4","brown3", "dodgerblue3"))+
  scale_shape_manual(values = c(17, 16, 15))


# tidy labels
colnames(MeansIncomeP.Bind)[1] <- "Income"
MeansIncomeP.Bind<-MeansIncomeP.Bind %>%
  select(everything(), -profile_AnnualHouseholdIncome)

MeansAllP.Bind <- rbind(
relabel_for_single_plot(MeansAgeP.Bind),  
relabel_for_single_plot(MeansGenderP.Bind),
relabel_for_single_plot(MeansEthnicityP.Bind),
relabel_for_single_plot(MeansEducationP.Bind),
relabel_for_single_plot(MeansHomeStatusP.Bind),
relabel_for_single_plot(MeansClassP.Bind),
relabel_for_single_plot(MeansFamClassP.Bind),
relabel_for_single_plot(MeansRegionP2.Bind),
relabel_for_single_plot(MeansIncomeP.Bind),
relabel_for_single_plot(MeansReligionP.Bind)
)

MeansAllP.Bind$Group<- gsub("profile_", "",MeansAllP.Bind$Group)

MeansAllP.Bind <- MeansAllP.Bind %>%
  separate(Group, into = c("Group", "Attribute"), sep=": ")

MeansAllP.Bind<- MeansAllP.Bind %>%
  mutate(Attribute = fct_reorder(Attribute, fit))
MeansAllP.Bind<- MeansAllP.Bind %>%
  mutate(Attribute = fct_relevel(Attribute,"Unknown", "Less than 5,199", "Between 5,200 and 15,599","Between 15,600 and 25,999", "Between 26,000 and 36,399", "Between 36,400 and 44,999",  "Between 45,000 and 59,999", "Between 60,000 and 99,999", "Greater than 100,000"))

MeansAllP.Bind<- MeansAllP.Bind %>%
  mutate(Group = dplyr::recode(Group, HomeStatus = "Home Status", AgeGroup = "Age", SubClass= "Class", SubFamClass = "Family Class"))

P_All_Party <- ggplot(MeansAllP.Bind, aes(x = Attribute, y=fit, col = Probabilities, shape = Probabilities)) + 
  geom_errorbar(aes(ymin=lwr, ymax=upr), width=.1, position= position_dodge(w=0.5)) +
  geom_point(position= position_dodge(w=0.5), size=2) +
  geom_hline(yintercept=50, linetype="dashed", 
             size=1, color="grey", alpha=0.5)+
  theme_classic()+
  ggtitle("Vote Conservative by Group") + theme(plot.title = element_text(hjust = 0.5)) +
  xlab("") + ylab("")+
  facet_grid(Group~., scales = "free_y", space = "free_y")+
  theme(legend.position="bottom", strip.text.y =element_text(angle = 0),
        panel.grid.major.y = element_line(colour = "grey95"),
        panel.background = element_rect(colour = "black"))+
  coord_flip(ylim= c(0, 100))+
  scale_color_manual(values = c("dodgerblue4","brown3", "dodgerblue3"))+
  scale_shape_manual(values = c(17, 16, 15))



```

```{r, fig.width=9,fig.height=12,out.width="\\linewidth",echo=FALSE,fig.cap="Average guess of vote versus BES estimates and known results by profile attribute for Brexit experiment. \\label{attributemeans_brexit}",fig.show='hold',fig.align='center'}
P_All_Brex
``` 

```{r, fig.width=9,fig.height=12,out.width="\\linewidth",echo=FALSE,fig.cap="Average guess of vote versus BES estimates and known results by profile attribute for party experiment. \\label{attributemeans_party}",fig.show='hold',fig.align='center'}
P_All_Party
``` 

In general, Figures \ref{attributemeans_brexit} and \ref{attributemeans_party} show that respondents' guesses are responsive to differences between groups.  While on average guessed Leave vote is slightly too high, the differences between class groups, regions, income groups, home ownership status, gender, ethnicity, education and age are all in the right direction and are close to the correct magnitude for many attributes.  Respondents appear to be substantially under-responsive to differences by age, income and ethnicity. In the party experiment, nearly all of the differences between groups are once again in the correct direction, with the sole exception of education.  Respondents thought that profiles with university degrees were more likely to be Conservatives than those without, when in the BES the relationship goes the other way.  Here, there is a substantial underestimation of age and regional differences, while the association with income is very close to correct.  

## Regression Analysis of Guesses by Attributes 

These one-attribute-at-a-time analyses tell us about the general tendency of respondents to hold accurate perceptions of profiles with different attributes.  But because profile attributes are correlated in the UK population, and therefore also in our experimental treatment distribution, the one-at-time analysis does not tell us the extent to which respondents are changing their responses due to particular profile attributes.  It could be that respondents only perceive the importance of some of these attributes, change their responses in response only to those attributes, but nonetheless appear responsive to other attributes which are correlated with the ones that they know about.  While our design's non-independent randomisation sacrifices experimental balance of profile attribute effects, the experimental design still rules out omitted variables and we can identify the causal effects of attributes subject to modelling assumptions [@delacuesta2019improving], which are in our analysis the assumption of additivity of the attribute effects on a logit scale.  The possibility of attribute confounding motivates moving to a multiple regression analysis of responses, to attempt to distinguish which of the profile attributes are influencing respondents.

The relevant benchmark for a regression model predicting respondent guesses as a function of profile attributes is the equivalent regression model predicting vote choice among BES profiles.  In the analysis below, we use as modelling assumptions a (fractional) logistic regression for the guess (rescaled to the $\left[0,1\right]$ interval) and a logistic regression for the binary vote choice, so that the coefficients are directly comparable.[^boundsviolations]  

[^boundsviolations]: We obtain very similar results using a linear probability model for both the guesses and the BES vote data, however this model does lead to invalid predictions for the binary vote choice for some profiles.

```{r,include=FALSE}

#The following chunk allows for a comparison between BES and guesses, modelling all profile attributes together. Models are estaimted in logit and linear form. Linear model lead to invalid predictions for the binary vote choice for some profiles


# Brexit Linear model, predicting guessed probability of leave with porfiles attributes as predictors
GuessedLeave<- lm(profile_Leave ~ profile_Gender+profile_AgeGroup+profile_Education+profile_Region+profile_SubClass+profile_SubFamClass+profile_HomeStatus+profile_Religion+profile_Ethnicity+profile_AnnualHouseholdIncome, weights=Brexit.Experiment.Clean$respondent_weights, data = Brexit.Experiment.Clean)
BESLeave<- lm(profile_Leave ~ profile_Gender+profile_AgeGroup+profile_Education+profile_Region+profile_SubClass+profile_SubFamClass+profile_HomeStatus+profile_Religion+profile_Ethnicity+profile_AnnualHouseholdIncome, weights=Brexit.BES.Clean$profile_weights, data = Brexit.BES.Clean)

# Brexit Logit model
Brexit.Experiment.Clean$LeaveProp <- Brexit.Experiment.Clean$profile_Leave/100

#Brexit.Sep is a dataset created to ease later combination
Brexit.Sep<- Brexit.Experiment.Clean %>%
select(LeaveProp, starts_with("profile"), respondent_weights)
colnames(Brexit.Sep)<-paste0(colnames(Brexit.Sep), "_")

GuessedLeaveLogit0 <- glm("LeaveProp_ ~ profile_Gender_ +profile_AgeGroup_ +profile_Education_ +profile_Region_ +profile_SubClass_ +profile_SubFamClass_ +profile_HomeStatus_ +profile_Religion_ +profile_Ethnicity_ +profile_AnnualHouseholdIncome_", weights=Brexit.Sep$respondent_weights_, data = Brexit.Sep, family=quasibinomial(link="logit"))

# Same regression with Brexit.Experiment.Clean dataset (guesses model)
GuessedLeaveLogit<-glm(LeaveProp ~ profile_Gender +profile_AgeGroup +profile_Education +profile_Region +profile_SubClass +profile_SubFamClass +profile_HomeStatus +profile_Religion +profile_Ethnicity +profile_AnnualHouseholdIncome, weights=Brexit.Experiment.Clean$respondent_weights, data = Brexit.Experiment.Clean, family=quasibinomial(link="logit"))


# Same regression with Brexit.BES.Clean dataset (BES model)
Brexit.BES.Clean$Leave.BES.Prop <- Brexit.BES.Clean$profile_Leave/100

#Brexit.Sep.BES is a dataset created to ease later combination
Brexit.Sep.BES<- Brexit.BES.Clean %>%
select(Leave.BES.Prop, starts_with("profile"))
colnames(Brexit.Sep.BES)<-paste0(colnames(Brexit.Sep.BES), "_")

BESLeaveLogit0 <- glm("Leave.BES.Prop_ ~ profile_Gender_ +profile_AgeGroup_ +profile_Education_ +profile_Region_ +profile_SubClass_ +profile_SubFamClass_ +profile_HomeStatus_ +profile_Religion_ +profile_Ethnicity_ +profile_AnnualHouseholdIncome_", weights=Brexit.Sep.BES$profile_weights_, data = Brexit.Sep.BES, family=quasibinomial(link="logit"))

# Same regression with Brexit.BES.Clean dataset (BES model)
BESLeaveLogit <- glm(Leave.BES.Prop ~ profile_Gender +profile_AgeGroup +profile_Education +profile_Region +profile_SubClass +profile_SubFamClass +profile_HomeStatus +profile_Religion +profile_Ethnicity +profile_AnnualHouseholdIncome, weights=Brexit.BES.Clean$profile_weights, data = Brexit.BES.Clean, family=quasibinomial(link="logit"))

#Plotting guesses and BES model together

P.Mult.Leave0<-multiplot(GuessedLeaveLogit0,BESLeaveLogit0, title = "Predictors of Voting Leave: Guessed versus BES", xlab = "Logistic Coefficents",
          ylab = "", innerCI = 0, outerCI = 2, lwdInner = 1,
          lwdOuter = 0.5, pointSize = 2, dodgeHeight = 0.5, color = "blue",
          shape = 16, linetype = 1, cex = 0.8, textAngle = 0,
          numberAngle = 90, zeroColor = "grey", zeroLWD = 1, zeroType = 2,
          single = T, scales = "fixed", ncol = length(unique(modelCI$Model)),
          sort = c("natural", "normal", "magnitude", "size", "alphabetical"),
          decreasing = FALSE, names = c("Guesses","BES"), numeric = FALSE, fillColor = "grey",
          alpha = 1/2, horizontal = FALSE, factors = NULL, only = NULL,
          shorten = TRUE, intercept = F, interceptName = "(Intercept)",
          coefficients = NULL, predictors = NULL, strict = FALSE,
          newNames = NULL, plot = TRUE, drop = FALSE, by = c("Coefficient",
                                                             "Model"), plot.shapes = FALSE, plot.linetypes = FALSE,
          legend.position =  "bottom",
          secret.weapon = FALSE, legend.reverse = FALSE, trans = identity)

P.Mult.Leave0$data<- P.Mult.Leave0$data %>%
  mutate(Coefficient = str_remove(Coefficient, "profile_")) %>%
  separate(Coefficient, into = c("Group", "Coefficient"), sep = "_") 
P.Mult.Leave0$data<- P.Mult.Leave0$data %>%
  mutate(Coefficient = fct_reorder(Coefficient, Value))
P.Mult.Leave0$data<- P.Mult.Leave0$data %>%
  mutate(Coefficient = fct_relevel(Coefficient,"Unknown", "Between 5,200 and 15,599","Between 15,600 and 25,999", "Between 26,000 and 36,399", "Between 36,400 and 44,999",  "Between 45,000 and 59,999", "Between 60,000 and 99,999", "Greater than 100,000"))

P.Mult.Leave0$data<- P.Mult.Leave0$data %>%
  mutate(Group = dplyr::recode(Group, HomeStatus = "Home Status", AgeGroup = "Age", SubClass= "Class", SubFamClass = "Family Class", AnnualHouseholdIncome = "Income"))
  
P.Mult.Leave <-P.Mult.Leave0+
  theme_classic()+
  ggtitle("Voting Leave: Guessed versus BES") + theme(plot.title = element_text(hjust = 0.5)) +
  facet_grid(Group~., scales = "free_y", space = "free_y")+
  theme(legend.position="bottom", strip.text.y =element_text(angle = 0),
        panel.grid.major.y = element_line(colour = "grey95"),
        panel.background = element_rect(colour = "black"))+
  scale_color_manual(values = c( "dodgerblue4", "brown3"))+
  scale_shape_manual(values = c(17, 16))

# Parties Linear models
GuessedConservative <- lm(profile_Con ~ profile_Gender+profile_AgeGroup+profile_Education+profile_Region+profile_SubClass+profile_SubFamClass+profile_HomeStatus+profile_Religion+profile_Ethnicity+profile_AnnualHouseholdIncome ,weights = Parties.Experiment.Clean$respondent_weights,data = Parties.Experiment.Clean)
RealConservative<- lm(profile_Con ~ profile_Gender+profile_AgeGroup+profile_Education+profile_Region+profile_SubClass+profile_SubFamClass+profile_HomeStatus+profile_Religion+profile_Ethnicity+profile_AnnualHouseholdIncome, weights=Parties.BES.Clean$profile_weights, data = Parties.BES.Clean)

# Parties Logstics models
Parties.Experiment.Clean$ConProp <- Parties.Experiment.Clean$profile_Con/100

# Party.Sep dataset created to to ease combination later
Party.Sep<- Parties.Experiment.Clean %>%
select(ConProp, starts_with("profile"), respondent_weights)
colnames(Party.Sep)<-paste0(colnames(Party.Sep), "_")

GuessedConservativeLogit0 <- glm("ConProp_ ~ profile_Gender_ +profile_AgeGroup_ +profile_Education_ +profile_Region_ +profile_SubClass_ +profile_SubFamClass_ +profile_HomeStatus_ +profile_Religion_ +profile_Ethnicity_ +profile_AnnualHouseholdIncome_", weights=Party.Sep$respondent_weights_, data = Party.Sep, family=quasibinomial(link="logit"))

# Same regression with Parties.Experiment.Clean (guesses)
GuessedConservativeLogit <- glm(ConProp ~ profile_Gender +profile_AgeGroup  +profile_Education  +profile_Region  +profile_SubClass  +profile_SubFamClass  +profile_HomeStatus  +profile_Religion  +profile_Ethnicity  +profile_AnnualHouseholdIncome , weights=Parties.Experiment.Clean$respondent_weights, data = Parties.Experiment.Clean, family=quasibinomial(link="logit"))

#Same regression with BES model
Parties.BES.Clean$profile_Con.Prop <- Parties.BES.Clean$profile_Con/100
Party.Sep.BES<- Parties.BES.Clean %>%
select(starts_with("profile"))
colnames(Party.Sep.BES)<-paste0(colnames(Party.Sep.BES), "_")

RealConservativeLogit0 <- glm("profile_Con.Prop_ ~ profile_Gender_ +profile_AgeGroup_ +profile_Education_ +profile_Region_ +profile_SubClass_ +profile_SubFamClass_ +profile_HomeStatus_ +profile_Religion_ +profile_Ethnicity_ +profile_AnnualHouseholdIncome_", weights=Party.Sep.BES$profile_weights_, data = Party.Sep.BES, family=quasibinomial(link="logit"))

RealConservativeLogit <- glm(profile_Con.Prop ~ profile_Gender +profile_AgeGroup +profile_Education +profile_Region +profile_SubClass +profile_SubFamClass +profile_HomeStatus +profile_Religion +profile_Ethnicity +profile_AnnualHouseholdIncome, weights=Parties.BES.Clean$profile_weights_, data = Parties.BES.Clean, family=quasibinomial(link="logit"))

# Plotting BES and Guesses together

P.Mult.Con0<-multiplot(GuessedConservativeLogit0, RealConservativeLogit0, title = "Voting Conservative: Guessed versus BES", xlab = "Logistic Coefficents",
          ylab = "", innerCI = 0, outerCI = 2, lwdInner = 1,
          lwdOuter = 0.5, pointSize = 2, dodgeHeight = 0.5, color = "blue",
          shape = 16, linetype = 1, cex = 0.8, textAngle = 0,
          numberAngle = 90, zeroColor = "grey", zeroLWD = 1, zeroType = 2,
          single = TRUE, scales = "fixed", ncol = length(unique(modelCI$Model)),
          sort = c("natural", "normal", "magnitude", "size", "alphabetical"),
          decreasing = FALSE, names = c("Guesses","BES"), numeric = FALSE, fillColor = "grey",
          alpha = 1/2, horizontal = FALSE, factors = NULL, only = NULL,
          shorten = TRUE, intercept = F, interceptName = "(Intercept)",
          coefficients = NULL, predictors = NULL, strict = FALSE,
          newNames = NULL, plot = TRUE, drop = FALSE, by = c("Coefficient",
                                                             "Model"), plot.shapes = FALSE, plot.linetypes = FALSE,
          legend.position = "bottom",
          secret.weapon = FALSE, legend.reverse = FALSE, trans = identity)

P.Mult.Con0$data<- P.Mult.Con0$data %>%
  mutate(Coefficient = str_remove(Coefficient, "profile_")) %>%
  separate(Coefficient, into = c("Group", "Coefficient"), sep = "_") 
P.Mult.Con0$data<- P.Mult.Con0$data %>%
  mutate(Coefficient = fct_reorder(Coefficient, Value))
P.Mult.Con0$data<- P.Mult.Con0$data %>%
  mutate(Coefficient = fct_relevel(Coefficient,"Unknown", "Between 5,200 and 15,599","Between 15,600 and 25,999", "Between 26,000 and 36,399", "Between 36,400 and 44,999",  "Between 45,000 and 59,999", "Between 60,000 and 99,999", "Greater than 100,000"))

P.Mult.Con0$data<- P.Mult.Con0$data %>%
  mutate(Group = dplyr::recode(Group, HomeStatus = "Home Status", AgeGroup = "Age", SubClass= "Class", SubFamClass = "Family Class", AnnualHouseholdIncome = "Income"))


P.Mult.Con<-P.Mult.Con0+
    theme_classic()+
  ggtitle("Voting Conservative: Guessed versus BES") + theme(plot.title = element_text(hjust = 0.5)) +
  facet_grid(Group~., scales = "free_y", space = "free_y")+
  theme(legend.position="bottom", strip.text.y =element_text(angle = 0),
        panel.grid.major.y = element_line(colour = "grey95"),
        panel.background = element_rect(colour = "black"))+
  scale_color_manual(values = c( "dodgerblue4", "brown3"))+
  scale_shape_manual(values = c(17, 16))


```



```{r, fig.width=9,fig.height=12,out.width="\\linewidth",echo=FALSE,fig.cap="Regression coefficients for guess of vote versus BES estimates by profile attribute for Brexit experiment. \\label{regression_brexit}",fig.show='hold',fig.align='center'}
P.Mult.Leave
``` 

```{r, fig.width=9,fig.height=12,out.width="\\linewidth",echo=FALSE,fig.cap="Regression coefficients for guess of vote versus BES estimates by profile attribute for party experiment. \\label{regression_party}",fig.show='hold',fig.align='center'}
P.Mult.Con
``` 

The individual coefficients shown in Figures \ref{regression_brexit} and \ref{regression_party} can be interpreted in a causal way. In other words, they represent the expected change in the odds of guessing a probability, by an average respondent, brought upon by a change in the presented profile from the base category to the measured category, averaged over the distribution of the other attributes. For example, the coefficient for "male" represents the expected change in odds of a guessed probabilities, for the average respondent, of being presented a random male profile rather than a random female profile, holding all other attributes constant.  Our findings follow largely similar patterns to the single attribute analysis from before.  There are some exceptions: we see responses tracking regional differences in the single attribute analyses in Figures \ref{attributemeans_brexit} and \ref{attributemeans_party}, but Figures \ref{regression_brexit} and \ref{regression_party} suggest that this is mostly because of demographic variation by region as opposed to direct effects of the region label.  Overall, the magnitudes of the partial associations are either close to correct or underestimated, but only in the case of education in the party experiment is the association significantly in the wrong direction.  Respondents are, on average, responsive to most of the attributes provided in the experiment, holding constant all of the others.

## Comparison of Predicted Probabilities



```{r,include=FALSE}

#This chunk allows for comparisons between the predicted probabilities of profiles voting in a certain way, implied by the BES model and the Guesses model.



#Brexit experiment
fitted_BES_Brex<-predict(BESLeaveLogit, newdata=Brexit.BES.Clean, type="response")
predicted_Experiment_Brex <- predict(GuessedLeaveLogit , newdata=Brexit.BES.Clean,type="response")
fitted_BES_Brexit<-data.frame("profile"= c(1:1695), fitted_BES_Brex)
predicted_Experiment_Brexit<-data.frame("profile"= c(1:1695), predicted_Experiment_Brex)
Relation.Models.Brexit<-merge(fitted_BES_Brexit, predicted_Experiment_Brexit, by="profile")


leave.predicted.plot <- ggplot(Relation.Models.Brexit, aes(x=fitted_BES_Brex, y= predicted_Experiment_Brex)) +
  geom_point(alpha = 0.5, col = "steelblue2")+
  geom_abline(intercept = 0, slope = 1)+
  ylim(0,1)+ 
  xlim(0,1)+
  ggtitle("Brexit Experiment") + 
  ggplot2::ylab("Predicted Probability Leave - Experiment")+
  ggplot2::xlab("Predicted Probability Leave - BES")+
  theme_classic()

#Parties experiment
fitted_BES_Con<- predict(RealConservativeLogit, newdata=Parties.BES.Clean,type="response")
predicted_Experiment_Con <- predict(GuessedConservativeLogit, newdata=Parties.BES.Clean,type="response")

fitted_BES_Conservative<-data.frame("profile"= c(1:1362), fitted_BES_Con)
predicted_Experiment_Conservative<-data.frame("profile"= c(1:1362), predicted_Experiment_Con)


Relation.Models.Con<-merge(fitted_BES_Conservative, predicted_Experiment_Conservative, by="profile")



parties.predicted.plot <- ggplot(Relation.Models.Con, aes(x= fitted_BES_Con, y=predicted_Experiment_Con)) +
  geom_point( alpha = 0.5, col="steelblue2")+
  geom_abline(intercept = 0, slope = 1)+
  xlim(0,1)+
  ylim(0,1)+
  ggtitle("Party Experiment") + 
  ggplot2::ylab("Predicted Probability Conservative - Experiment")+
  ggplot2::xlab("Predicted Probability Conservative - BES")+
  theme_classic()

```


```{r, fig.width=8,fig.height=4,out.width="\\linewidth",echo=FALSE,fig.cap="Predicted probabilities based on experimental responses as a function of predicted probabilities based on BES vote choice. \\label{predicted_prob_plots}",fig.show='hold',fig.align='center'}
grid.arrange(leave.predicted.plot,parties.predicted.plot,nrow=1)
``` 


If we use both of these models to construct predicted probabilities for the BES profiles, we see that the predicted probabilities are correlated to a substantial degree.  For the Brexit experiment, the predicted probabilities constructed using the BES vote data and using the experimental guesses are correlated at `r round(cor(predicted_Experiment_Brex,fitted_BES_Brex),2)`.  For the party experiment, the equivalent correlation is `r round(cor(predicted_Experiment_Con,fitted_BES_Con),2)`.  The fact that the coefficients from the model fit to the guesses tend to be attenuated relative to the model fit on the BES vote choice data means that the predicted probabilities from the former are also attenuated with respect to the predicted probabilities from the latter (see Figure \ref{predicted_prob_plots}).


# Determinants of Respondent Accuracy

Thus far, we have focused on whether respondents' guesses vary in the right ways given variation in the profiles, on average.  But average variation in the profiles is not the only variation of interest.  Is the good average performance the result of high quality individual-level guesses, or simply a lot of idiosyncratic error that cancels out?  Figure \ref{guesses_by_fitted_values}, by comparison to Figure \ref{predicted_prob_plots}, shows that there is a great deal of idiosyncratic error.  Which respondents to our experiment are more or less able to provide accurate responses?  There are many ways to answer these questions, but here we use two measures of the accuracy of guesses, one which assesses the quality of the percentages reported by respondents as probabilistic forecasts, and one which assess only the direction of the guess.

First, we use the Brier Score, a tool from forecast evaluation, to assess respondents guesses as probabilistic predictions [@brier1950verification]. If $N$ is the total number of predictions, $f_i$ is the probability reported by a respondent and $o_i$ is the true vote of the profile shown to that respondent (which may take the values of $1$ or $0$):

$$\text{Brier Score} = \frac{1}{N} \sum_{i=1}^n (f_i - o_i)^2 $$

Smaller Brier scores imply better predictions. Here, the measure enables us to assess the accuracy of respondents' guesses about the referendum and election vote by comparing their prediction to the actual votes associated with the voter profile that they observed.  A convenient feature of the score is that it is simply an average of a quantity that we can calculate for each response.  This means that in addition to calculating the score overall, we can fit regression models for $Y_i = (f_i - o_i)^2$ to model how the Brier score, which is to say predictive accuracy, varies as a function of respondent characteristics.  Note that this depends on only the guess and the true value for each response to our survey experiment, so we can model this quantity as a function of profile characteristics, respondent characteristics, or both.

Second, we use "correct dichotomised guesses" to assess respondents' guesses in a way that reduces sensitivity to their ability to use a probability scale effectively.  Here, if the profile is actually a Leave voter, we count any guess from 51% Leave to 100% Leave as correct, a guess of 50% as half correct, and any guess from 0% to 49% Leave as incorrect.  This approximates the assessment that we could have done if we had asked respondents simply for their best guess, rather than for a probability.  Merely assessing whether the respondent's guess was in the correct direction makes sense if one is concerned that respondents understand that probabilities above 50% imply that an option is more likely than the alternative, but find it difficult to express the degree of confidence using a probability scale.

```{r,include=FALSE}



#Individual Brier Score Brexit
Brexit.Experiment.Clean$BrierScore<- ((Brexit.Experiment.Clean$profile_Leave/100)-Brexit.Experiment.Clean$profile_Leave.Real)^2

BrierScoreTotal<-weighted.mean(Brexit.Experiment.Clean$BrierScore, w=Brexit.Experiment.Clean$respondent_weights, na.rm = T)


#Individual Brier Score Parties
Parties.Experiment.Clean$BrierScore<- (Parties.Experiment.Clean$profile_Conservative.Real-(Parties.Experiment.Clean$profile_Con/100))^2

Parties.Experiment.Clean$BrierScoreBinary <-  ((0.5+0.5*sign((Parties.Experiment.Clean$profile_Con - 50)))-Parties.Experiment.Clean$profile_Conservative.Real)^2

BrierScoreTotalParties<-mean(Parties.Experiment.Clean$BrierScore, w=Parties.Experiment.Clean$respondent_weights, na.rm = T)

```


```{r,include=FALSE}

#Average Brier score

#Predicted probabilities for every profile, using BES model
fitted_BESCoef_BrexExp<-predict(BESLeaveLogit, newdata=Brexit.Experiment.Clean,type="response")
fitted_BESCoef_BrexExp<-data.frame(Brexit.Experiment.Clean, fitted_BESCoef_BrexExp)
fitted_BESCoef_PartyExp<-predict(RealConservativeLogit, newdata=Parties.Experiment.Clean,type="response")
fitted_BESCoef_PartyExp<-data.frame(Parties.Experiment.Clean, fitted_BESCoef_PartyExp)

fitted_BESCoef_BrexExp<-fitted_BESCoef_BrexExp %>%
dplyr::rename(fittedBrexExp = fitted_BESCoef_BrexExp)
fitted_BESCoef_PartyExp<-fitted_BESCoef_PartyExp %>%
  dplyr::rename(fittedPartyExp = fitted_BESCoef_PartyExp)

#Brier score Parties
fitted_BESCoef_PartyExp$BrierScore.fitted<- (fitted_BESCoef_PartyExp$fittedPartyExp-(fitted_BESCoef_PartyExp$profile_Con/100))^2
BrierScoreTotalParty.fitted<-mean(fitted_BESCoef_PartyExp$BrierScore.fitted, w=Parties.Experiment.Clean$respondent_weights, na.rm = T)

#Brier Score Brexit
fitted_BESCoef_BrexExp$BrierScore.fitted<- (fitted_BESCoef_BrexExp$fittedBrexExp-(fitted_BESCoef_BrexExp$profile_Leave/100))^2
BrierScoreTotalBrex.fitted<-mean(fitted_BESCoef_BrexExp$BrierScore.fitted, w=Parties.Experiment.Clean$respondent_weights, na.rm = T)

#Brier score by respondent characteristics


#Predicting Brier Score with politcal attention only. Political attention as factor variable
Brexit.Experiment.Clean$respondent_PoliticalAttention<-factor(Brexit.Experiment.Clean$respondent_PoliticalAttention,
                                                  levels=c("0"[order(1)],"1"[order(2)],
                                                           "2"[order(3)],"3"[order(4)],
                                                           "4"[order(5)],"5"[order(6)],
                                                           "6"[order(7)],"7"[order(8)],
                                                           "8"[order(9)],"9"[order(10)],
                                                           "10"[order(11)]))
BS_byAttention_Brexit2<-lm(BrierScore~respondent_PoliticalAttention, weights=Brexit.Experiment.Clean$respondent_weights, data = Brexit.Experiment.Clean)

new.dat <-data.frame(respondent_PoliticalAttention=c("0",  "1",  "2",  "3",
                                            "4",  "5",  "6",  "7",  
                                            "8",  "9", "10"))
BS_byAttention_Brexit2<-data.frame(new.dat, predict(BS_byAttention_Brexit2, newdata = new.dat, interval = 'confidence'))

BS_byAttention_Brexit2$respondent_PoliticalAttention=factor(BS_byAttention_Brexit2$respondent_PoliticalAttention,
                                                  levels=c("0"[order(1)],"1"[order(2)],
                                                           "2"[order(3)],"3"[order(4)],
                                                           "4"[order(5)],"5"[order(6)],
                                                           "6"[order(7)],"7"[order(8)],
                                                           "8"[order(9)],"9"[order(10)],
                                                           "10"[order(11)]))


brier.by.attention.leave <- ggplot(BS_byAttention_Brexit2, aes(x=respondent_PoliticalAttention, y=fit, group = 1)) + 
  geom_errorbar(aes(ymin=lwr, ymax=upr), width=.1) +
  #geom_line() +
  geom_point() +
  ggtitle("Brexit Experiment") + theme(plot.title = element_text(hjust = 0.5)) +
  xlab("Political Attention") + ylab("Brier Score")+
  scale_y_continuous(limits = c(0.2,0.5), breaks = seq(0.2,0.5, by = 0.05)) +
  theme_classic()

#Predicting Brier Score with all respondents' attributes

Brexit.Experiment.Clean$respondent_PoliticalAttention<-as.numeric(as.character(Brexit.Experiment.Clean$respondent_PoliticalAttention))

model.BscAllRespondentR.Brexit<-lm(BrierScore~respondent_PoliticalAttention+respondent_pastvote_2017+respondent_pastvote_EURef+respondent_Age+respondent_Education+respondent_Gender+respondent_Region, weights=Brexit.Experiment.Clean$respondent_weights, data = Brexit.Experiment.Clean)

BS_byAttention_Brexit<-lm(BrierScore~respondent_PoliticalAttention, weights=Brexit.Experiment.Clean$respondent_weights, data = Brexit.Experiment.Clean)






#Parties

#Brier score by respondent characteristics

#Predicting Brier Score with politcal attention only. Political attention as factor variable


Parties.Experiment.Clean$respondent_PoliticalAttention<-factor(Parties.Experiment.Clean$respondent_PoliticalAttention,
                                               levels=c("0"[order(1)],"1"[order(2)],
                                                        "2"[order(3)],"3"[order(4)],
                                                        "4"[order(5)],"5"[order(6)],
                                                        "6"[order(7)],"7"[order(8)],
                                                        "8"[order(9)],"9"[order(10)],
                                                        "10"[order(11)]))


BS_byAttention_Parties<-lm(BrierScore~respondent_PoliticalAttention, weights=Parties.Experiment.Clean$respondent_weights, data = Parties.Experiment.Clean)
new.dat <- data.frame(respondent_PoliticalAttention=c("0",  "1",  "2",  "3",
                                            "4",  "5",  "6",  "7",  
                                            "8",  "9", "10"))
BS_byAttention_Parties2<-data.frame(new.dat, predict(BS_byAttention_Parties, newdata = new.dat, interval = 'confidence'))
BS_byAttention_Parties2$respondent_PoliticalAttention <- factor(BS_byAttention_Parties2$respondent_PoliticalAttention,
                                                   levels=c("0"[order(1)],"1"[order(2)],
                                                            "2"[order(3)],"3"[order(4)],
                                                            "4"[order(5)],"5"[order(6)],
                                                            "6"[order(7)],"7"[order(8)],
                                                            "8"[order(9)],"9"[order(10)],
                                                            "10"[order(11)]))


brier.by.attention.con <- ggplot(BS_byAttention_Parties2, aes(x=respondent_PoliticalAttention, y=fit, group = 1)) + 
  geom_errorbar(aes(ymin=lwr, ymax=upr), width=.1) +
  #geom_line() +
  geom_point() +
  ggtitle("Party Experiment") + theme(plot.title = element_text(hjust = 0.5)) +
  xlab("Political Attention") + ylab("Brier Score")+
  scale_y_continuous(limits = c(0.2,0.5), breaks = seq(0.2,0.5, by = 0.05)) +
  theme_classic()

#Predicting Brier Score with all respondents' attributes

Parties.Experiment.Clean$respondent_PoliticalAttention<-as.numeric(as.character(Parties.Experiment.Clean$respondent_PoliticalAttention))
model.BscAllRespondentR.party<-lm(BrierScore~respondent_PoliticalAttention+respondent_pastvote_2017+respondent_pastvote_EURef+respondent_Age+respondent_Education+respondent_Gender+respondent_Region, weights=Parties.Experiment.Clean$respondent_weights, data = Parties.Experiment.Clean)



#Preparing data for dichotomous analysis in Parties experiment

fitted_BESCoef_BrexExp<- fitted_BESCoef_BrexExp %>%
  mutate(profile_Leave.Dich = case_when( profile_Leave<50 ~ "Remain",
                                         profile_Leave>50 ~ "Leave",
                                         profile_Leave==50 ~ "50-50"))
fitted_BESCoef_PartyExp<- fitted_BESCoef_PartyExp %>%
  mutate(profile_Con.Dich = case_when( profile_Con<50 ~ "Labour",
                                         profile_Con>50 ~ "Conservative",
                                         profile_Con==50 ~ "50-50"))

fitted_BESCoef_BrexExp <- fitted_BESCoef_BrexExp %>%
  mutate(profile_Leave.RealN = case_when(profile_Leave.Real == 1 ~ "Leave" , 
                                          profile_Leave.Real == 0 ~ "Remain"))

#Creating variable that equals 1 for correct dichotomous guess (and 0.5 for "50-50"). Brexit
fitted_BESCoef_BrexExp <- fitted_BESCoef_BrexExp %>%
  mutate(Correct.Dich.Guess.Brex = case_when(profile_Leave.Dich=="50-50" ~ 0.5,
                                             profile_Leave.Dich==profile_Leave.RealN ~ 1,
                                             profile_Leave.Dich!=profile_Leave.RealN ~ 0))

dclus1<-svydesign(ids=~0, weights=fitted_BESCoef_BrexExp$respondent_weights, data=fitted_BESCoef_BrexExp)
meanleave<-svymean(~Correct.Dich.Guess.Brex, dclus1 ,deff=F, na.rm =T)
CI<-confint(meanleave)
CI.Correct.Brex.Dich<-data.frame("Correct"="Brexit", "fit"=meanleave[1]*100, "lwr"=CI[1,1]*100,"upr"=CI[1,2]*100)

#Creating variable that equals 1 for correct dichotomous guess (and 0.5 for "50-50"). Parties
fitted_BESCoef_PartyExp <- fitted_BESCoef_PartyExp %>%
  mutate(profile_Conservative.RealN = case_when(profile_Conservative.Real == 1 ~ "Conservative" , 
                                          profile_Conservative.Real == 0 ~ "Labour"))
fitted_BESCoef_PartyExp <- fitted_BESCoef_PartyExp %>%
  mutate(Correct.Dich.Guess.Party = case_when(profile_Con.Dich=="50-50" ~ 0.5,
                                             profile_Con.Dich==profile_Conservative.RealN ~ 1,
                                             profile_Con.Dich!=profile_Conservative.RealN ~ 0))

dclus1<-svydesign(ids=~0, weights=fitted_BESCoef_PartyExp$respondent_weights, data=fitted_BESCoef_PartyExp)
meanCon<-svymean(~Correct.Dich.Guess.Party, dclus1 ,deff=F, na.rm =T)
CI<-confint(meanCon)
CI.Correct.Party.Dich<-data.frame("Correct"="Party", "fit"=meanCon[1]*100, "lwr"=CI[1,1]*100,"upr"=CI[1,2]*100)

#Comparing dichotomized guess and dichotomized BES model prediction

##Dichotomous guess versus profiles dichotomous fitted vote
fitted_BESCoef_BrexExp <- fitted_BESCoef_BrexExp %>%
  mutate(fittedBrexExp.Dich = case_when(fittedBrexExp==0.5 ~ "50-50",
                                        fittedBrexExp<0.5 ~ "Remain",
                                        fittedBrexExp>0.5 ~ "Leave"))
fitted_BESCoef_PartyExp <- fitted_BESCoef_PartyExp %>%
  mutate(fittedPartyExp.Dich = case_when(fittedPartyExp==0.5 ~ "50-50",
                                         fittedPartyExp<0.5 ~ "Labour",
                                         fittedPartyExp>0.5 ~ "Conservative"))

fitted_BESCoef_BrexExp <- fitted_BESCoef_BrexExp %>%
  mutate(Correct.Dich.Guess.Brex.Fitted= case_when(profile_Leave.Dich== "50-50" ~ 0.5,
                                       profile_Leave.Dich==fittedBrexExp.Dich ~ 1,
                                       profile_Leave.Dich!=fittedBrexExp.Dich ~ 0))

fitted_BESCoef_PartyExp <- fitted_BESCoef_PartyExp %>%
  mutate(Correct.Dich.Guess.Party.Fitted= case_when(profile_Con.Dich== "50-50" ~ 0.5,
                                       profile_Con.Dich==fittedPartyExp.Dich ~ 1,
                                       profile_Con.Dich!=fittedPartyExp.Dich ~ 0))

dclus1<-svydesign(ids=~0, weights=fitted_BESCoef_BrexExp$respondent_weights, data=fitted_BESCoef_BrexExp)
meanleave<-svymean(~Correct.Dich.Guess.Brex.Fitted, dclus1 ,deff=F, na.rm =T)
CI<-confint(meanleave)
CI.Correct.Brex.Dich.Fitted<-data.frame("Correct for fitted"="Brexit", "fit"=meanleave[1]*100, "lwr"=CI[1,1]*100,"upr"=CI[1,2]*100)

dclus1<-svydesign(ids=~0, weights=fitted_BESCoef_PartyExp$respondent_weights, data=fitted_BESCoef_PartyExp)
meanCon<-svymean(~Correct.Dich.Guess.Party.Fitted, dclus1 ,deff=F, na.rm =T)
CI<-confint(meanCon)
CI.Correct.Party.Dich.Fitted<-data.frame("Correct for fitted"="Party", "fit"=meanCon[1]*100, "lwr"=CI[1,1]*100,"upr"=CI[1,2]*100)


dclus1<-svydesign(ids=~0, weights=fitted_BESCoef_PartyExp$respondent_weights, data=fitted_BESCoef_PartyExp)
propleave<-svyciprop(~I(Correct.Dich.Guess.Party.Fitted==1),dclus1, method="lo", df=degf(dclus1))
CI.est<-data.frame("fit"=as.matrix(propleave)*100)
CI.low <-data.frame("lwr"=as.matrix(attr(propleave, "ci")[1])*100)
CI.high <-data.frame("upr"=as.matrix(attr(propleave, "ci")[2])*100)
CI.Correct.Party.Dich.Fitted<-data.frame("Correct for fitted"="Party", CI.est, CI.low,CI.high)

#Predicting dichotomized guess succes by respondents' characteristics
#Brexit

fitted_BESCoef_BrexExp <- fitted_BESCoef_BrexExp%>%
  rename( c( "Correct.Dich.Guess.Brex" ="Correct.Dich.Guess"))
fitted_BESCoef_PartyExp <- fitted_BESCoef_PartyExp %>%
  rename( c( "Correct.Dich.Guess.Party" ="Correct.Dich.Guess"))

fitted_BESCoef_BrexExp$respondent_PoliticalAttention<-as.numeric(as.character(fitted_BESCoef_BrexExp$respondent_PoliticalAttention))

model.Correct.Brexit.Dich<-lm(Correct.Dich.Guess~respondent_PoliticalAttention+respondent_pastvote_2017+respondent_pastvote_EURef+respondent_Age+respondent_Education+respondent_Gender+respondent_Region, weights=fitted_BESCoef_BrexExp$respondent_weights, data = fitted_BESCoef_BrexExp)

#Parties
fitted_BESCoef_PartyExp$respondent_PoliticalAttention<-as.numeric(as.character(fitted_BESCoef_PartyExp$respondent_PoliticalAttention))

model.Correct.Party.Dich<-lm(Correct.Dich.Guess~respondent_PoliticalAttention+respondent_pastvote_2017+respondent_pastvote_EURef+respondent_Age+respondent_Education+respondent_Gender+respondent_Region, weights=fitted_BESCoef_PartyExp$respondent_weights, data = fitted_BESCoef_PartyExp)
```


The overall Brier score for all responses (using survey weights) is `r round(BrierScoreTotal,3)` for the Brexit experiment and `r round(BrierScoreTotalParties,3)` for the party experiment. In both cases this is worse (higher) than the score of 0.25 that results from simply guessing 50% for every profile in both experiments. This is not surprising given that many respondents provide 0% and 100% responses, which are always overly confident probabilistic assessments given the limited predictive power of the profile attributes that respondents saw in the experiment.  To generate a benchmark for what good guesses would look like in this task, we can compare the guessed results to the Brier score obtained by using the BES predicted probabilities as $f_i$.  Any remaining difference can be attributed to either the respondents’ lack of knowledge or their difficulty at communicating it as a probability.  These benchmark Brier scores are `r round(BrierScoreTotalBrex.fitted,3)`  and `r round(BrierScoreTotalParty.fitted,3)` for the Brexit and party experiments respectively. These values are far better (lower) than the respondents achieved as well as being substantially better than what would result from guessing 50% on all profiles, because the profile variables are moderately predictive of vote choices in both experiments. 

We can assess the extent to which poor reporting of probabilities is the problem by analysing the proportion of correct guesses when we dichotomise the guesses as described earlier.  We find that, under this criterion, `r round(CI.Correct.Brex.Dich [1,2],1)`%  (95% interval `r round(CI.Correct.Brex.Dich [1,3],1)`-`r round(CI.Correct.Brex.Dich [1,4],1)`) of respondents in the Brexit experiment correctly guessed the vote of the respective profile. Similarly, `r round(CI.Correct.Party.Dich [1,2],1)`%  (95% interval `r round(CI.Correct.Party.Dich [1,3],1)`-`r round(CI.Correct.Party.Dich [1,4],1)`) of respondents in the party experiment guessed correctly.   If we similarly dichotomize the fitted probabilities from the benchmark model fit to the BES data, we find that `r round(CI.Correct.Brex.Dich.Fitted [1,2],1)`%  (95% interval `r round(CI.Correct.Brex.Dich.Fitted [1,3],1)`-`r round(CI.Correct.Brex.Dich.Fitted [1,4],1)`) of profiles in the Brexit experiment and `r round(CI.Correct.Party.Dich.Fitted [1,2],1)`%  (95% interval `r round(CI.Correct.Party.Dich.Fitted [1,3],1)`-`r round(CI.Correct.Party.Dich.Fitted [1,4],1)`) in the party experiment could have been guessed correctly based on the dichotomised probabilities from the logistic regression fit on the BES data.  By this standard, respondents perform reasonably, given the limits of what was possible using a basic demographic model with the data that they were presented with.  The fact that the guesses look so much better when assessed dichotomously reinforces the point that the poor predictive performance by Brier score derives in large part from the fact that people struggle to think probabilistically or to report their beliefs in this way [e.g. @kahneman2011thinking;@baron2014two;@atanasov2017distilling].


```{r,include=FALSE}

#Comparing fitted probabilities (BES) with guessed probabilities (not fitted guessed probabilities)
#Comparing predicted (fitted) probabilities



guess.by.fitted.brexit <- ggplot(fitted_BESCoef_BrexExp, aes(x=fittedBrexExp, y= profile_Leave)) + 
  geom_point(alpha=0.5, col = "steelblue2")+
  stat_smooth(se=F, method='lm', col = "black")+
  coord_cartesian (ylim=c(0,100), xlim=c(0,1))+
  ggtitle("Brexit Experiment") + 
  ggplot2::ylab("Guessed percentage")+
  ggplot2::xlab("Predicted Probability")+
  theme_classic()

#Parties experiment
model.prob.party<-lm(profile_Con~fittedPartyExp, data=fitted_BESCoef_PartyExp)
#tab_model(model.prob.party, show.se = TRUE, show.stat = FALSE, digits = 3, title="Relation guessed probabilities with fitted model")

guess.by.fitted.party <- ggplot(fitted_BESCoef_PartyExp, aes(x=fittedPartyExp, y= profile_Con)) +
  geom_point(alpha=0.5, col = "steelblue2")+
  stat_smooth(se=F, method='lm', col = "black")+
  coord_cartesian (ylim=c(0,100), xlim=c(0,1))+
  ggtitle("Party Experiment") + 
  ggplot2::ylab("Guessed percentage")+
  ggplot2::xlab("Predicted Probability")+
  theme_classic()


```


```{r, fig.width=8,fig.height=4,out.width="\\linewidth",echo=FALSE,fig.cap="Guessed percentages for each response in the experiment as a function of the predicted probability for the experimentally provided profile using the BES vote regression model. \\label{guesses_by_fitted_values}",fig.show='hold',fig.align='center'}
grid.arrange(guess.by.fitted.brexit,guess.by.fitted.party,nrow=1)
``` 

## Respondent-level Predictors of Accuracy

In Table \ref{brierregression} we report the results of a regression predicting Brier scores and correct dichotomous guess proportions, for both experiments.  The strongest source of respondent-level heterogeneity across the two experiments is that respondents who pay more attention to politics tend to do a much better job at guessing the probabilities of someone voting in a given way.  Going from the lowest (0) to the highest (10) level of attention is associated with an increase of `r round(100*10*coef(model.Correct.Brexit.Dich)[grep("Attention",names(coef(model.Correct.Brexit.Dich)))],1)` and `r round(100*10*coef(model.Correct.Party.Dich)[grep("Attention",names(coef(model.Correct.Party.Dich)))],1)` percentage points in the proportion of profiles with the correct dichotomised guess in the Brexit and party experiments, respectively and all else equal.  The fact that we see this association in both Brier scores and correct dichotomised guess tells us that it is primarily an association with knowledge, rather than with the ability to accurately report probabilities.

Political attention is the only respondent attribute that is consistently and strongly predictive of Brier scores as well as correct dichotomised guesses across both experiments.  Higher educational attainment is associated with better (lower) Brier scores on the Brexit experiment, but not the party experiment.  In both experiments, the region where respondents make the worst guesses by Brier score, all else equal, is London.  This difference is only marginally significant from other regions, and is not present in the party experiment when assessed by dichotomised guess, but it is plausible that people in London might have a poorer understanding of how people around the UK vote than do respondents elsewhere, simply because London is a bit of a political outlier among UK regions.

\singlespacing <!-- for below table -->

```{r, echo = FALSE, results='asis', out.width="97%", fig.show='hold'}

texreg(list(model.BscAllRespondentR.Brexit, model.BscAllRespondentR.party, model.Correct.Brexit.Dich, model.Correct.Party.Dich), 
       float.pos="t",
       single.row=FALSE,
       digits = 3,
       fontsize = "footnotesize",
       stars = c(0.01, 0.05, 0.1),
       longtable=TRUE,
       use.packages=FALSE,
       caption="Coefficient Estimates for a Regression Model for Brier Score and Correct Dichotomized Guess by Respondent Characteristics \\label{brierregression}",
       custom.header= list("Brier Score" = 1:2, "Correct Dichotomized Guess" = 3:4),
       custom.model.names =c("Brexit Exp.","Party Exp.", "Brexit Exp.", "Party Exp."),
       custom.coef.names= c("Intercept","Political Attention", "Party Vote: Labour", "Party Vote: Liberal Democrat", "Party Vote: SNP", "Party Vote: Plaid Cymru", "Party Vote: UKIP", "Party Vote: Green", "Party Vote: Other", "Party Vote: Don't Know", "EU Ref Vote: Leave", "EU Ref Vote: Did not vote", "Age", "Education Level: 1", "Education Level: 2", "Education Level: 3", "Education Level: 4", "Education Level: 5 and above", "Education Level: Other", "Female", "Region: North West", "Region: Yorkshire and the Humber", "Region: East Midlands", "Region: West Midlands", "Region: East of England",  "Region: London", "Region: South East", "Region: South West", "Region: Wales", "Region: Scotland"))
```

\doublespacing

Finally, we also assessed whether accuracy was related to aggregate similarity between the respondent and the evaluated profile, summarizing the difference between the respondent and the treatment profile using the Mahalonobis distance [@mahalanobis1936generalized]. Table 1 in the online appendix shows the result of this analysis. We find no evidence that respondents are more or less accurate in guessing the votes of profiles that are more or less similar to their own profile.[^MahalonobisRegression]

[^MahalonobisRegression]: The Mahalonobis distance was measured using six attributes with available information on respondents. These attributes were: gender, region of residence, ethnicity, income, age, and education level.

The association between political attention and accuracy in guesses is not linear across the eleven categories of the 0-10 self-report, but is largely explained by the poor (high) scores of the lowest two groups in the political attention scale.  As Figure \ref{brier_by_attention} shows, despite the different sets of respondents in the two experiments, there is a distinctive non-monotonic pattern to the predictive performance of respondents across the difference levels of the attention measure, with those giving the "1" response on the 0-10 scale performing worst and those giving the "9" response performing best.  The non-monotonicity likely reflects a non-monotonicity in how people respond to the self-assessment of political attention as a function of their real awareness of politics rather than non-monotonicity in the relationship between political attention and performance in this experiment.  While it is clear that the 0s and 1s perform substantially worse than individuals expressing greater attention to politics, there is no clear trend above the two lowest levels: there is little difference between those who report a political attention of 2 and those who report a 10.

We note here the echo of Converse's conclusion that both the middle and higher strata of political sophistication can recognize the group alignment of political divides.  In contrast, the lowest strata of political sophistication pays "too little attention to either the parties or the current candidates to be able to say anything about them" (Converse, 1964, p.16). Specifically, Converse claimed, the lack of linking information between the parties or policies and social groups' interests explain this lack of connection, which is consistent with our findings here. 


```{r, fig.width=8,fig.height=4,out.width="\\linewidth",echo=FALSE,fig.cap="Brier score by respondent self-reported attention to politics. \\label{brier_by_attention}",fig.show='hold',fig.align='center', fig.pos="H"}
grid.arrange(brier.by.attention.leave,brier.by.attention.con,nrow=1)
``` 

```{r,include=FALSE}
#Mahalabonis distance

#Prepating data for Mahalabonis distnace calculation. Creating dummies representing matching attribute of porfile and respondent

#Party

#Gender
Parties.Experiment.Clean<- Parties.Experiment.Clean %>%
  mutate(Match.Gender = ifelse(respondent_Gender == profile_Gender, 1, 0))
#Region
Parties.Experiment.Clean<- Parties.Experiment.Clean %>%
  mutate(respondent_Region = recode(respondent_Region,
                                    "East Midlands" = "the East Midlands",
                                    "East of England" = "the East of England",
                                    "Yorkshire and the Humber" = "Yorkshire & Humber"),
         respondent_Region = as.character(respondent_Region),
         profile_Region = as.character(profile_Region))
fitted_BESCoef_PartyExp<- fitted_BESCoef_PartyExp %>%
  mutate(respondent_Region = recode(respondent_Region,
                                    "East Midlands" = "the East Midlands",
                                    "East of England" = "the East of England",
                                    "Yorkshire and the Humber" = "Yorkshire & Humber"),
         respondent_Region = as.character(respondent_Region),
         profile_Region = as.character(profile_Region))

Parties.Experiment.Clean<- Parties.Experiment.Clean %>%
  mutate(Match.Region = ifelse(respondent_Region == profile_Region, 1, 0))
#Education
Parties.Experiment.Clean<- Parties.Experiment.Clean %>%
  mutate(Match.Education =
           case_when(respondent_Education ==  "Level 5 and above" & profile_Education == "Holds a university degree" ~ 1,
                     respondent_Education !=  "Level 5 and above" & profile_Education != "Holds a university degree" ~ 1,
                     TRUE ~ 0))
#Age
Parties.Experiment.Clean<- Parties.Experiment.Clean %>%
  mutate(Match.Age =
           ifelse(abs(profile_Age - respondent_Age) > 10, 0, 1))

#Ethnicity. What to do with unknown?

Parties.Experiment.Clean<- Parties.Experiment.Clean %>%
  mutate(respondent_Ethnicity = fct_collapse(respondent_Ethnicity,
    White = c("English / Welsh / Scottish / Northern Irish / British", "Irish", "Gypsy or Irish Traveller", "Any other White background"),
    Mixed = c("White and Black African", "White and Black Caribbean", "White and Asian", "Any other Mixed / Multiple ethnic background"),
    Asian = c("Indian", "Pakistani", "Bangladeshi", "Chinese", "Any other Asian background"),
    Black = c("African", "Caribbean", "Any other Black / African / Caribbean background"),
    Other = c("Any other ethnic group", "Arab"),
    Unknown = "Prefer not to say"))
Parties.Experiment.Clean<- Parties.Experiment.Clean %>%
  mutate(
    respondent_Ethnicity = as.character(respondent_Ethnicity),
    profile_Ethnicity =as.character(profile_Ethnicity)
  )
fitted_BESCoef_PartyExp<- fitted_BESCoef_PartyExp %>%
  mutate(respondent_Ethnicity = fct_collapse(respondent_Ethnicity,
    White = c("English / Welsh / Scottish / Northern Irish / British", "Irish", "Gypsy or Irish Traveller", "Any other White background"),
    Mixed = c("White and Black African", "White and Black Caribbean", "White and Asian", "Any other Mixed / Multiple ethnic background"),
    Asian = c("Indian", "Pakistani", "Bangladeshi", "Chinese", "Any other Asian background"),
    Black = c("African", "Caribbean", "Any other Black / African / Caribbean background"),
    Other = c("Any other ethnic group", "Arab"),
    Unknown = "Prefer not to say"))
Parties.Experiment.Clean<- Parties.Experiment.Clean %>%
  mutate(
    respondent_Ethnicity = as.character(respondent_Ethnicity),
    profile_Ethnicity =as.character(profile_Ethnicity)
  )

Parties.Experiment.Clean<- Parties.Experiment.Clean %>%
  mutate(Match.Ethnicity = ifelse(respondent_Ethnicity == profile_Ethnicity, 1, 0))

#Income (matches are not perfect)
levels(Parties.Experiment.Clean$profile_AnnualHouseholdIncome)
Parties.Experiment.Clean<- Parties.Experiment.Clean %>%
  mutate(respondent_AnnualHouseholdIncome = fct_collapse(respondent_AnnualHouseholdIncome,
     "Less than 15,599" = c("under Â£5,000 per year", "Â£5,000 to Â£9,999 per year","Â£10,000 to Â£14,999 per year"),
    "Between 15,600 and 25,999" = c("Â£15,000 to Â£19,999 per year", "Â£20,000 to Â£24,999 per year"),
    "Between 26,000 and 44,999" = c("Â£25,000 to Â£29,999 per year", "Â£30,000 to Â£34,999 per year", "Â£35,000 to Â£39,999 per year", "Â£40,000 to Â£44,999 per year"),
    "Between 45,000 and 99,999" = c("Â£45,000 to Â£49,999 per year",   "Â£50,000 to Â£59,999 per year", "Â£60,000 to Â£69,999 per year", "Â£70,000 to Â£99,999 per year"),
    "Greater than 100,000" = c("Â£100,000 to Â£149,999 per year", "Â£150,000 and over")),
    profile_AnnualHouseholdIncome = fct_collapse(profile_AnnualHouseholdIncome,
      "Less than 15,599" = c("Less than 5,199", "Between 5,200 and 15,599"),
      "Between 45,000 and 99,999" = c("Between 45,000 and 59,999", "Between 60,000 and 99,999"),
      "Between 26,000 and 44,999" = c("Between 26,000 and 36,399", "Between 36,400 and 44,999")))
Parties.Experiment.Clean<- Parties.Experiment.Clean %>%
  mutate(
    respondent_AnnualHouseholdIncome = as.character(respondent_AnnualHouseholdIncome),
    profile_AnnualHouseholdIncome = as.character(profile_AnnualHouseholdIncome))
Parties.Experiment.Clean<- Parties.Experiment.Clean %>%
  mutate(Match.Income = ifelse(respondent_AnnualHouseholdIncome == profile_AnnualHouseholdIncome, 1, 0))
fitted_BESCoef_PartyExp<- fitted_BESCoef_PartyExp %>%
  mutate(respondent_AnnualHouseholdIncome = fct_collapse(respondent_AnnualHouseholdIncome,
     "Less than 15,599" = c("under Â£5,000 per year", "Â£5,000 to Â£9,999 per year","Â£10,000 to Â£14,999 per year"),
    "Between 15,600 and 25,999" = c("Â£15,000 to Â£19,999 per year", "Â£20,000 to Â£24,999 per year"),
    "Between 26,000 and 44,999" = c("Â£25,000 to Â£29,999 per year", "Â£30,000 to Â£34,999 per year", "Â£35,000 to Â£39,999 per year", "Â£40,000 to Â£44,999 per year"),
    "Between 45,000 and 99,999" = c("Â£45,000 to Â£49,999 per year",   "Â£50,000 to Â£59,999 per year", "Â£60,000 to Â£69,999 per year", "Â£70,000 to Â£99,999 per year"),
    "Greater than 100,000" = c("Â£100,000 to Â£149,999 per year", "Â£150,000 and over")))

#covariance distribution of the treatment
Treatment.P <- Parties.Experiment.Clean %>%
  select(starts_with("Match")) 

#Mahalonobis distance
Dx <- as.matrix((1-Treatment.P)) # to flip to match = 0
Sx <- var(Dx, na.rm=T)
M.PartySqr <- matrix(0, 5064)
for(i in 1:5064){
M.PartySqr[i,1] <- t(Dx[i,]) %*% inv(Sx) %*% Dx[i,]
}
M.Party <- sqrt(M.PartySqr)
Parties.Experiment.Clean$mahalanobis2<-M.Party
#Brexit
#Matching matrices for the respondents to our experiment and the treatment profiles


#Gender
Brexit.Experiment.Clean<- Brexit.Experiment.Clean %>%
  mutate(Match.Gender = ifelse(respondent_Gender == profile_Gender, 1, 0))
#Region
Brexit.Experiment.Clean<- Brexit.Experiment.Clean %>%
  mutate(respondent_Region = recode(respondent_Region,
                                    "East Midlands" = "the East Midlands",
                                    "East of England" = "the East of England",
                                    "Yorkshire and the Humber" = "Yorkshire & Humber"),
         respondent_Region = as.character(respondent_Region),
         profile_Region = as.character(profile_Region))
Brexit.Experiment.Clean<- Brexit.Experiment.Clean %>%
  mutate(Match.Region = ifelse(respondent_Region == profile_Region, 1, 0))
fitted_BESCoef_BrexExp<- fitted_BESCoef_BrexExp %>%
  mutate(respondent_Region = recode(respondent_Region,
                                    "East Midlands" = "the East Midlands",
                                    "East of England" = "the East of England",
                                    "Yorkshire and the Humber" = "Yorkshire & Humber"),
         respondent_Region = as.character(respondent_Region),
         profile_Region = as.character(profile_Region))


#Education
Brexit.Experiment.Clean<- Brexit.Experiment.Clean %>%
  mutate(Match.Education =
           case_when(respondent_Education ==  "Level 5 and above" & profile_Education == "Holds a university degree" ~ 1,
                     respondent_Education !=  "Level 5 and above" & profile_Education != "Holds a university degree" ~ 1,
                     TRUE ~ 0))
#Age
Brexit.Experiment.Clean<- Brexit.Experiment.Clean %>%
  mutate(Match.Age =
           ifelse(abs(profile_Age - respondent_Age) > 10, 0, 1))

#Ethnicity. What to do with unknown?

Brexit.Experiment.Clean<- Brexit.Experiment.Clean %>%
  mutate(respondent_Ethnicity = fct_collapse(respondent_Ethnicity,
                                             White = c("English / Welsh / Scottish / Northern Irish / British", "Irish", "Gypsy or Irish Traveller", "Any other White background"),
                                             Mixed = c("White and Black African", "White and Black Caribbean", "White and Asian", "Any other Mixed / Multiple ethnic background"),
                                             Asian = c("Indian", "Pakistani", "Bangladeshi", "Chinese", "Any other Asian background"),
                                             Black = c("African", "Caribbean", "Any other Black / African / Caribbean background"),
                                             Other = c("Any other ethnic group", "Arab"),
                                             Unknown = "Prefer not to say"))
Brexit.Experiment.Clean<- Brexit.Experiment.Clean %>%
  mutate(
    respondent_Ethnicity = as.character(respondent_Ethnicity),
    profile_Ethnicity =as.character(profile_Ethnicity)
  )
Brexit.Experiment.Clean<- Brexit.Experiment.Clean %>%
  mutate(Match.Ethnicity = ifelse(respondent_Ethnicity == profile_Ethnicity, 1, 0))

fitted_BESCoef_BrexExp<- fitted_BESCoef_BrexExp %>%
  mutate(respondent_Ethnicity = fct_collapse(respondent_Ethnicity,
                                             White = c("English / Welsh / Scottish / Northern Irish / British", "Irish", "Gypsy or Irish Traveller", "Any other White background"),
                                             Mixed = c("White and Black African", "White and Black Caribbean", "White and Asian", "Any other Mixed / Multiple ethnic background"),
                                             Asian = c("Indian", "Pakistani", "Bangladeshi", "Chinese", "Any other Asian background"),
                                             Black = c("African", "Caribbean", "Any other Black / African / Caribbean background"),
                                             Other = c("Any other ethnic group", "Arab"),
                                             Unknown = "Prefer not to say"))


#Income (matches are not perfect)
levels(Brexit.Experiment.Clean$profile_AnnualHouseholdIncome)
Brexit.Experiment.Clean<- Brexit.Experiment.Clean %>%
  mutate(respondent_AnnualHouseholdIncome = fct_collapse(respondent_AnnualHouseholdIncome,
                                                         "Less than 15,599" = c("under Â£5,000 per year", "Â£5,000 to Â£9,999 per year","Â£10,000 to Â£14,999 per year"),
                                                         "Between 15,600 and 25,999" = c("Â£15,000 to Â£19,999 per year", "Â£20,000 to Â£24,999 per year"),
                                                         "Between 26,000 and 44,999" = c("Â£25,000 to Â£29,999 per year", "Â£30,000 to Â£34,999 per year", "Â£35,000 to Â£39,999 per year", "Â£40,000 to Â£44,999 per year"),
                                                         "Between 45,000 and 99,999" = c("Â£45,000 to Â£49,999 per year",   "Â£50,000 to Â£59,999 per year", "Â£60,000 to Â£69,999 per year", "Â£70,000 to Â£99,999 per year"),
                                                         "Greater than 100,000" = c("Â£100,000 to Â£149,999 per year", "Â£150,000 and over")),
         profile_AnnualHouseholdIncome = fct_collapse(profile_AnnualHouseholdIncome,
                                                      "Less than 15,599" = c("Less than 5,199", "Between 5,200 and 15,599"),
                                                      "Between 45,000 and 99,999" = c("Between 45,000 and 59,999", "Between 60,000 and 99,999"),
                                                      "Between 26,000 and 44,999" = c("Between 26,000 and 36,399", "Between 36,400 and 44,999")))
Brexit.Experiment.Clean<- Brexit.Experiment.Clean %>%
  mutate(
    respondent_AnnualHouseholdIncome = as.character(respondent_AnnualHouseholdIncome),
    profile_AnnualHouseholdIncome = as.character(profile_AnnualHouseholdIncome))
Brexit.Experiment.Clean<- Brexit.Experiment.Clean %>%
  mutate(Match.Income = ifelse(respondent_AnnualHouseholdIncome == profile_AnnualHouseholdIncome, 1, 0))

fitted_BESCoef_BrexExp<- fitted_BESCoef_BrexExp %>%
  mutate(respondent_AnnualHouseholdIncome = fct_collapse(respondent_AnnualHouseholdIncome,
                                                         "Less than 15,599" = c("under Â£5,000 per year", "Â£5,000 to Â£9,999 per year","Â£10,000 to Â£14,999 per year"),
                                                         "Between 15,600 and 25,999" = c("Â£15,000 to Â£19,999 per year", "Â£20,000 to Â£24,999 per year"),
                                                         "Between 26,000 and 44,999" = c("Â£25,000 to Â£29,999 per year", "Â£30,000 to Â£34,999 per year", "Â£35,000 to Â£39,999 per year", "Â£40,000 to Â£44,999 per year"),
                                                         "Between 45,000 and 99,999" = c("Â£45,000 to Â£49,999 per year",   "Â£50,000 to Â£59,999 per year", "Â£60,000 to Â£69,999 per year", "Â£70,000 to Â£99,999 per year"),
                                                         "Greater than 100,000" = c("Â£100,000 to Â£149,999 per year", "Â£150,000 and over")))



#covariance distribution of the treatment
Treatment.B <- Brexit.Experiment.Clean %>%
  select(starts_with("Match")) 
mahalanobisB<-data.frame("mahalanobis" = mahalanobis(Treatment.B,center=F,var(Treatment.B, na.rm=T)))
Brexit.Experiment.Clean<-bind_cols(Brexit.Experiment.Clean, mahalanobisB)

#Mahalonobis distance

Dx <- as.matrix((1-Treatment.B)) # to flip to match = 0
Sx <- var(Dx, na.rm=T)
M.BrexitSqr <- matrix(0, 5082)
for(i in 1:5082){
  M.BrexitSqr[i,1] <- t(Dx[i,]) %*% inv(Sx) %*% Dx[i,]
}
M.Brexit <- sqrt( M.BrexitSqr)
Brexit.Experiment.Clean$mahalanobis2<-M.Brexit


#Using Mahalanobis distance to predict brier score and dichotomous guess

#Brexit
#Brier Score
model.Brier.MahalB<-lm(BrierScore~mahalanobis2, weights=Brexit.Experiment.Clean$respondent_weights, data = Brexit.Experiment.Clean)
model.Brier.Mahal.AllB<-lm(BrierScore~mahalanobis2 +respondent_PoliticalAttention+respondent_pastvote_2017+respondent_pastvote_EURef+respondent_Age+respondent_Education+respondent_Gender+respondent_Region+ respondent_Ethnicity, weights=Brexit.Experiment.Clean$respondent_weights, data = Brexit.Experiment.Clean)

#Dichotomous guess
fitted_BESCoef_BrexExp$mahalanobis2<- M.Brexit


model.Dich.Mahal.B <- lm(Correct.Dich.Guess~mahalanobis2, weights=fitted_BESCoef_BrexExp$respondent_weights, data = fitted_BESCoef_BrexExp)
model.Dich.Mahal.AllB <- lm(Correct.Dich.Guess~mahalanobis2+ respondent_PoliticalAttention+respondent_pastvote_2017+respondent_pastvote_EURef+respondent_Age+respondent_Education+respondent_Gender+respondent_Region + respondent_Ethnicity, weights=fitted_BESCoef_BrexExp$respondent_weights, data = fitted_BESCoef_BrexExp)

#Party
#Brier Score
model.Brier.MahalP<-lm(BrierScore~mahalanobis2, weights=Parties.Experiment.Clean$respondent_weights, data = Parties.Experiment.Clean)
model.Brier.Mahal.AllP<-lm(BrierScore~mahalanobis2 +respondent_PoliticalAttention+respondent_pastvote_2017+respondent_pastvote_EURef+respondent_Age+respondent_Education+respondent_Gender+respondent_Region + respondent_Ethnicity, weights=Parties.Experiment.Clean$respondent_weights, data = Parties.Experiment.Clean)

#Dichotomous guess
fitted_BESCoef_PartyExp$mahalanobis2<- M.Party

model.Dich.Mahal.P <- lm(Correct.Dich.Guess~mahalanobis2, weights=fitted_BESCoef_PartyExp$respondent_weights, data = fitted_BESCoef_PartyExp)
model.Dich.Mahal.AllP <- lm(Correct.Dich.Guess~mahalanobis2+ respondent_PoliticalAttention+respondent_pastvote_2017+respondent_pastvote_EURef+respondent_Age+respondent_Education+respondent_Gender+respondent_Region + respondent_Ethnicity, weights=fitted_BESCoef_PartyExp$respondent_weights, data = fitted_BESCoef_PartyExp)

```

# Discussion and Conclusion

Our analysis examines both individual-level and aggregate-level accuracy, because both are important features of public understanding of how different social groups vote.  It is important to know if there are systematic biases that show up in the aggregate, but also whether individuals tend to have much usable information about these questions.  If individual citizens have wildly divergent beliefs about the likely voter behaviour of their fellow citizens, that is important to know even if these divergent beliefs average out to something close to reality. There is a long "wisdom of crowds" tradition of observing that while individuals may be inaccurate, they may nonetheless be accurate on average [@wallsten2001understanding;@surowiecki2005wisdom].  This is often explained as resulting from individuals each having only a few pieces of relevant information, for example their social networks [e.g. @leiter2018social], with the process of averaging cancelling out the resulting idiosyncratic errors.  This pattern of individual level imprecision combined with aggregate-level accuracy is clearly evident in our data, not only because different individuals may know about the political associations of different attributes, but also because of errors in probability reporting.  Individual citizens are poor at guessing how other specific citizens vote but the average guesses broadly reflect how major political cleavages relate to a variety of demographic characteristics. 

The novelty of the Brexit divide means that respondents must have paid recent attention to these political cleavages, a finding further confirmed by the role of political attention in predicting accuracy, both for the older cleavage of party and the newer cleavage of Brexit. However, at the same time that we see evidence of very recent information intake in the Brexit experiment, there are some attributes which suggest that party stereotypes are "sticky" [@green2004partisan;@lupu2013party].  In the party experiment education and age are strongly predictive of the actual distribution of voters, while class and economic attributes are less so. Respondents underestimate the age relationship, which makes sense in that it is newly strong; the education association with voting *used* to be that holding a degree predicted voting Tory [@heath2016understanding;@ball2013portrait], but that is no longer true.   With respect to the "old" cleavage of party, some of respondents' errors may be because they have not updated in response to political realignments. 

We find some egotistic bias, where respondents overestimate the probabilities that others have voted as they did.  However, we do not find that $p(vote|X)$ accuracy is worse when respondents are asked about profiles that are more dissimilar to them, the egotistic bias applies across similar and dissimilar profiles.  Thus it seems that performance in this task is less dependent on respondent's immediate social environment and more on general political knowledge. It remains to be studied if guesses on p(X) might be more dependent on immediate social environment. This contrasts with @carlson2021experimental findings that respondents guesses become more accurate (less biased) for profiles that are more similar to the respondents' own profile. They explain this association as a manifestation of different-trait bias, as individuals are likely to assume that out-group members are more homogeneous than in-group members.  This could be a relationship that is present for the political attitudes included in Carlson and Hill's experiment but not for demographic characteristics.

The different political contexts of the US and UK make comparisons to many of the studies we cite difficult.  While our results are broadly consistent with the US study which asks the most similar questions [@carlson2021experimental], we cannot rule out the possibility that US and UK citizens simply respond very differently to these kinds of survey prompts.  While both countries have relatively strong two party systems, there is no shortage of political differences that could be relevant to how citizens perceive one another.  We do not know whether UK studies asking questions similar to those of @ahler2018parties would find similar results to those that they find.

Regardless, our findings present an interesting puzzle in light of recent work by @ahler2018parties and @claassen2019which.  Those papers indicate that when asked *compositional* questions, about the demographic distributions of party supporters, respondents tend to stereotype or caricature, overstating the demographic distinctiveness of parties.  The accuracy of perceptions is lower for citizens with greater interest in politics [@ahler2018parties, p969].  Our paper asks a *behavioural* question about the voting of individuals with a given set of characteristics, $p(vote|X)$ rather than $p(X|vote)$, and finds no tendency of respondents to overstate the relevance of any particular attributes to guessing the vote choice of an individual.  The accuracy of guesses is higher for those paying more attention to politics.  Aside from the differing political context, one possible reconciliation of these results is that respondents' inability to report percentages/proportions accurately simply manifests itself in different ways in the different experimental designs.  Another possible reconciliation is that people are just inconsistent, giving answers to one kind of question that are mathematically inconsistent with the answers they would give to the other kind of question, for example, because of the representativeness heuristic that @ahler2020typecast propose.  

Another way of phrasing these key outstanding puzzles, which goes to the heart of the concerns raised by @ahler2018parties, is to ask whether citizens *really* believe their overconfident guesses.  Is the problem with reporting or with their beliefs?  @ahler2018parties are unable to substantially improve the accuracy of party compositions by providing incentives to reduce expressive misreporting or by providing population base rates, which they take to suggest that citizens' beliefs are meaningfully erroneous (p969-971).  @ahler2018parties further demonstrate through a series of experiments (p976-978) that the effect of correcting misperceptions about party composition is small, but non-zero, for perceptions about the extremity of opposing partisans.

For our experiment, the corresponding question is whether, for example, when someone reports 100% probability of a particular profile voting Leave, that level of certainty really guides how they would interact with and think about someone with those characteristics.  Are citizens going through the world making *extremely strong* snap judgements about the political alignments of those around them, at least when given occasion to think about the politics of those people at all?  Our finding that there is no one dominant pattern of such snap judgements in the aggregate does not mean that individuals are not doing this. Indeed, the implication of their numerical responses taken literally is that they are.  The extent to which this is a reporting problem, as opposed to a belief problem, is less amenable to the kinds of tests used by Ahler and Sood, since the objects of evaluation in our experiments are unknown individuals rather than parties about which respondents already have other views that might be influenced by a corrective treatment.  

The most compelling way forward would be to ask a much richer set of questions to individual respondents, including questions about $p(vote|X)$ and $p(X|vote)$ as well as the base rates $p(vote)$ and $p(X)$, in order to better establish which responses are consistent with one another and with reality, and which are not.  While past studies have now analysed all of these quantities, they have done so in different contexts and individually rather than all in the same survey.  A study of this type would be a useful next step in clarifying the complicated pattern of findings across this study and those that have been published previously.

\newpage

# References





